Stack.hs

{-# LANGUAGE GADTs #-}

{- |
Module     : $Header$
Description: Functionality for generating & manipulating a stack.
Copyright  : (c) Alexander Berntsen 2015
License    : GPL-3

Maintainer : alexander@plaimi.net
-} module Clac.Stack where

import Control.Applicative
  (
  (<$>),
  (<|>),
  (<*>),
  )
import Control.Arrow
  (
  second,
  )
import Data.Fixed
  (
  mod',
  )
import Data.List
  (
  find,
  )
import Data.Tree
  (
  Tree (Node),
  Forest,
  )
import Data.Tree.Pretty
  (
  drawVerticalTree,
  )
import Numeric.Special.Trigonometric
  (
  acot,
  acoth,
  acsc,
  acsch,
  asec,
  asech,
  cot,
  coth,
  csc,
  csch,
  sec,
  sech,
  )
import Safe
  (
  readMay,
  )
-- | A stack item. 'Snum' is usually a number. 'Sop' is an 'Op' and a 'String'
-- description of the 'Op'.
data StackItem a where
  Snum :: Show a => a -> StackItem a
  Sop  :: {op :: Op a
          ,desc :: String
          }
          -> StackItem a
-- | 'show' of an 'Snum' is 'show' of its parametre. 'show' of an 'Sop' is
-- its 'desc'.
instance Show (StackItem a) where
  show (Snum a)  = show a
  show (Sop _ a) = a

-- | An operator for the stack. 'Bop' is a binary operator. 'Uop' is a unary
-- operator. 'C' is a constant. 'Neq' is the next equation operator.
data Op a where
  Bop :: (a -> a -> a) -> Op a
  Uop :: (a -> a) -> Op a
  C   :: a -> Op a
  Neq :: Op a

os :: (Floating a, Real a) => [(StackItem a, String)]
-- | List of all the valid operators, with their description.
os = [( Sop (Bop (+))          "+",     "+:\t\taddition"                     )
     ,( Sop (Bop (-))          "-",     "-:\t\tsubtraction"                  )
     ,( Sop (Bop (*))          "*",     "*:\t\tmultiplication"               )
     ,( Sop (Bop (*))          "x",     "*:\t\tmultiplication"               )
     ,( Sop (Bop (/))          "/",     "/:\t\tdivision"                     )
     ,( Sop (Bop (**))         "^",     "^:\t\tpower of"                     )
     ,( Sop (Bop mod')         "%",     "%:\t\tmodulo"                       )
     ,( Sop (Bop mod')         "mod",   "mod:\t\tmodulo"                     )
     ,( Sop (Bop logBase)      "log-n", "log-n:\t\tlog-n: log rhs / log lhs" )
     ,( Sop (Uop negate)       "neg",   "neg:\t\tnegation"                   )
     ,( Sop (Uop abs)          "abs",   "abs:\t\tabsolute value"             )
     ,( Sop (Uop log)          "ln",    "ln:\t\tnatural logarithm"           )
     ,( Sop (Uop $ logBase 10) "lg",    "ln:\t\tcommon logarithm"            )
     ,( Sop (Uop sin)          "sin",   "sin:\t\tsine function"              )
     ,( Sop (Uop cos)          "cos",   "cos:\t\tcosine function"            )
     ,( Sop (Uop tan)          "tan",   "tan:\t\ttangent function"           )
     ,( Sop (Uop asin)         "asin",  "asine:\t\tarcsine function"         )
     ,( Sop (Uop acos)         "acos",  "acosine:\tarccosine function"       )
     ,( Sop (Uop atan)         "atan",  "arctan:\t\tarctangent function"     )
     ,( Sop (Uop csc)          "csc",   "csc:\t\tcosecant function"          )
     ,( Sop (Uop sec)          "sec",   "sec:\t\tsecant function"            )
     ,( Sop (Uop cot)          "cot",   "cot:\t\tcotangent function"         )
     ,( Sop (Uop acsc)         "acsc",  "acsc:\t\tarccosecant function"      )
     ,( Sop (Uop asec)         "asec",  "asec:\t\tarcsecant function"        )
     ,( Sop (Uop acot)         "acot",  "acot:\t\tarccotangent function"     )
     ,( Sop (Uop csch)         "csch",  "csch:\t\thb-cosecant function"      )
     ,( Sop (Uop sech)         "sech",  "sech:\t\thb-secant function"        )
     ,( Sop (Uop coth)         "coth",  "coth:\t\thb-cotangent function"     )
     ,( Sop (Uop acsch)        "acsch", "acsch:\t\thb-arccosecant function"  )
     ,( Sop (Uop asech)        "asech", "asech:\t\thb-arcsecant function"    )
     ,( Sop (Uop acoth)        "acoth", "acoth:\t\thb-arccotangent function" )
     ,( Sop (Uop sqrt)         "sqrt",  "sqrt:\t\tsquare root function"      )
     ,( Sop (C   pi)           "pi",    "pi:\t\tpi constant"                 )
     ,( Sop (C   (exp 1))      "e",     "e:\t\tEuler's number constant"      )
     ,( Sop Neq                ",",     ",:\t\tstart a new equation"         )
     ]

b :: (Floating a, Real a, Read a, Show a)
  => String -> [StackItem a] -> [StackItem a]
-- | Build a [@'StackItem' a@]. Parse each item of the passed in equation
-- 'String' with 'p' and put it on the accumulator if valid.
b x ac = case p x of
           Just q  -> q:ac
           Nothing -> ac

p :: (Floating a, Real a, Read a, Show a) => String -> Maybe (StackItem a)
-- | Parse a 'String'. Try to look it up in 'os' as a 'Sop'. If that's
-- unsuccessful, try to read it as an 'Snum'. If that's unsuccessful, return
-- 'Nothing'.
p i = find ((== i) . desc) (fst <$> os) <|> Snum <$> readMay i

t :: Show a => [StackItem a] -> Forest String -> Tree String
-- | Generate an answer tree for the passed in [@'StackItem' a@]. Unrecognised
-- tokens are represented with a dejected but carefree emote.
t (Sop (Bop _) o:ss) (n:m:ts) = t ss (Node o [m, n]:ts)
t (Sop (Uop _) o:ss) (m:ts)   = t ss (Node o [m]:ts)
t (Sop (C   _) c:ss) ts       = t ss (Node c []:ts)
t (Snum n:ss)  ts             = t ss (Node (show n) []:ts)
t []           (n:_)          = n
t _            _              = Node "¯\\_(ツ)_/¯" []

s :: Show a => [StackItem a] -> [StackItem a] -> Maybe a
-- | Solve a [@'StackItem' a@].
s (Sop (Bop o) _:ss) (Snum n:Snum m:ts) = s ss (Snum (m `o` n):ts)
s (Sop (Uop o) _:ss) (Snum m:ts)        = s ss (Snum (o m):ts)
s (Sop (C   c) _:ss) ts                 = s ss (Snum c:ts)
s (n:ss)             ts                 = s ss (n:ts)
s []                 (Snum n:_)         = Just n
s _                  _                  = Nothing

sa :: (Floating a, Real a, Show a, Read a)
   => [[String]] -> [(Maybe a, String)]
-- | Solve a bunch of equations with 's', and return a
-- [(@'Maybe' a@, 'String')] with the solution (if there was one), and a tree
-- representing the solution.
sa = map $ (second drawVerticalTree . (((,) . (`s` []))
 <*> (`t` []))) . foldr b []