{-# OPTIONS -fglasgow-exts #-}

module Eg.Calculator where

import Test.FIT.Fixture
import Test.FIT.ColumnFixture
import Data.IORef
import Data.Char
import Data.Dynamic

data CalculatorState = CalculatorState
  { calcVolts :: Float
  , calcWatts :: Float
  , calcFlash :: Bool
  , calcKey :: String
  , calcRegs :: [Float]
  } deriving Typeable

setCalcVolts s v = s { calcVolts = v }
setCalcWatts s v = s { calcVolts = v }
setCalcFlash s v = s { calcFlash = v }
setCalcKey s v = s { calcKey = v }
setCalcRegs s v = s { calcRegs = v }

getState :: ColumnFixture -> IO CalculatorState
getState cf = getDynamicState (columnFixtureState cf)

setState :: ColumnFixture -> CalculatorState -> IO ()
setState cf v = setDynamicState (columnFixtureState cf) v


isNumeric "" = False
isNumeric [c] = isDigit c
isNumeric (c1:c2:cs) =
  (isDigit c1) || (c1 == '-' && isDigit c2)

set_xx f ret upd val = do
  s <- getState f
  setState f (upd s val)
  return ret
get_xx f sel = getState f >>= return . sel

get_volts f = get_xx f calcVolts

set_key f p = set_xx f p setCalcKey (bodyToText p)
get_key f = get_xx f calcKey
set_regs f r = set_xx f () setCalcRegs r
get_regs f = get_xx f calcRegs
set_flash f v = set_xx f () setCalcFlash v
get_flash f = get_xx f calcFlash


radians d = (d * pi) / 180

binOp f op = do
  a <- pop_reg f; b <- pop_reg f; push_reg f (op b a)


get_reg n f = do
  regs <- get_regs f
  return (head (drop (n-1) regs))

check_reg n f p = get_reg n f >>= check f p
  

shift_reg f = do
  r <- get_reg 1 f 
  push_reg f r

push_reg f r = do
  regs <- get_regs f
  set_regs f (r:regs)

pop_reg f = do
  regs <- get_regs f
  case regs of
    (r:rs) -> do
      set_regs f rs
      return r
    _ -> return 0

---------------------- Public fixture methods ------------------
--
-- These are the methods that are dynamically invoked.

x f p = check_reg 1 f p
y f p = check_reg 2 f p
z f p = check_reg 3 f p
t f p = check_reg 4 f p

volts f p = set_xx f p setCalcVolts (read (bodyToText p))
-- We'll check watts here, event thought they aren't really used.  
watts f p = get_xx f calcWatts >>= check f p
points f p = get_volts f >>= \v -> check f p (v < 3.4)
flash f p = get_flash f >>= check f p

key f p = do
  set_flash f False
  let k = bodyToText p
  set_key f p
  if isNumeric k
    then push_reg f (read k)
    else do
      case k of
        "enter" -> shift_reg f
        "clx" -> pop_reg f >> push_reg f 0
        "clr" -> set_regs f [0,0,0,0]
        "chs" -> do r <- pop_reg f; push_reg f (-r)
        "+" -> binOp f (+)
        "*" -> binOp f (*)
        "-" -> binOp f (-)
        "/" -> do
          a <- pop_reg f
          if a /= 0
            then do b <- pop_reg f; push_reg f (b / a)
            else do push_reg f 0; set_flash f True
        "x^y" -> do
          -- most binary ops take top of stack as RHS argument for op,
          -- but not ^ (on this machine).
          a <- pop_reg f; b <- pop_reg f; push_reg f (a ** b)
        "sin" -> do r <- pop_reg f; push_reg f (sin (radians r))
        otherwise -> error ("Can't do key: " ++ k)
  return p

----------------------------------------------------------------

newCalcFixture bf = do
  cf <- newColumnFixture bf
  setState cf (CalculatorState 0 0.5 False "" [0,0,0,0])
  return cf

processFixture :: ProcessFixture
processFixture bf p = do
  f <- newCalcFixture bf
  doTable f p