old/alacarte/calc.icl

   1 module calc
   2
   3 import StdEnv
   4 import Data.Tuple
   5 import Data.Either
   6
   7 :: Calculator = Calculator
   8 instance zero Calculator where zero = Calculator
   9 :: Memory =: Memory Int
  10 instance zero Memory where zero = Memory 0
  11 :: SquareRoot = SquareRoot
  12 instance zero SquareRoot where zero = SquareRoot
  13
  14 :: Instructions = Push Int | Add | Sub | Mul | Div
  15 :: MemInstructions = MC | MR | MP
  16 :: SqrtInstructions = Sqrt
  17
  18 class calculator i c :: i [Int] c -> ([Int], c) | zero c
  19
  20 instance calculator Instructions Calculator
  21 where
  22         calculator (Push i) stack c = ([i:stack], c)
  23         calculator Add stack c = (binop (+) stack, c)
  24         calculator Sub stack c = (binop (-) stack, c)
  25         calculator Mul stack c = (binop (*) stack, c)
  26         calculator Div stack c = (binop (/) stack, c)
  27
  28 instance calculator MemInstructions Memory
  29 where
  30         calculator MC stack _ = (stack, Memory 0)
  31         calculator MR stack (Memory i) = ([i:stack], Memory i)
  32         calculator MP [i:stack] _ = (stack, Memory i)
  33         calculator MP _ _ = abort "Not enough elements on the stack"
  34
  35 instance calculator SqrtInstructions SquareRoot
  36 where
  37         calculator Sqrt [i:stack] c = ([toInt (sqrt (toReal i)):stack], c)
  38         calculator Sqrt _ _ = abort "Not enough elements on the stack"
  39
  40 instance calculator (Either i1 i2) (c1, c2) | calculator i1 c1 & calculator i2 c2 & zero c1 & zero c2
  41 where
  42         calculator (Left a) stack (c1, c2) = appSnd (flip tuple c2) (calculator a stack c1)
  43         calculator (Right b) stack (c1, c2) = appSnd (tuple c1) (calculator b stack c2)
  44
  45 instance zero (a, b) | zero a & zero b where zero = (zero, zero)
  46
  47 binop op [l,r:stack] = [op l r:stack]
  48 binop _ _ = abort "Not enough elements on the stack"
  49
  50 Start = calculator instruction [9] state
  51
  52 instruction :: (Either Instructions (Either MemInstructions SqrtInstructions))
  53 instruction = Right (Right Sqrt)
  54
  55 state :: (Calculator, (Memory, SquareRoot))
  56 state = zero