slide-dsl/src/SlideRule.hs

{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DataKinds #-}
module SlideRule where

import Control.Applicative
import Control.Monad.Trans.State
import Data.Fixed (mod')
import Numeric

newtype SlideRule a = SlideRule (State SlideState a)
  deriving (Monad, Applicative, Functor)

data SlideState = SlideState
  { slideWheel  :: Double
  , slideCursor :: Double
  }

initialState :: SlideState
initialState = SlideState
  { slideWheel = 0
  , slideCursor = 0
  }

runSlideRule :: SlideRule a -> a
runSlideRule (SlideRule m) = evalState m initialState

printAnswer :: IsOnWheel pos => SlideRule (Scale pos) -> String
printAnswer s = showFFloat (Just 3) (runSlideRule (readCursor =<< s)) ""

instance Show a => Show (SlideRule a) where
  show = show . runSlideRule

data ScalePosition = OnWheel | OffWheel

class    IsOnWheel (pos :: ScalePosition) where
  scaleWheel :: scale pos -> Bool
instance IsOnWheel OnWheel  where scaleWheel _ = True
instance IsOnWheel OffWheel where scaleWheel _ = False

data Scale (w :: ScalePosition) = Scale
  { scaleName :: String
  , scaleFun  :: Double -> Double
  , scaleFun' :: Double -> Double
  }

cScale :: Scale OnWheel
cScale = Scale
  { scaleName = "C"
  , scaleFun  = logBase 10
  , scaleFun' = (10**)
  }

ciScale :: Scale OnWheel
ciScale = Scale
  { scaleName = "CI"
  , scaleFun  = \x -> mod' (1-logBase 10 x) 1
  , scaleFun' = \x -> 10** mod' (1-x) 1
  }

dScale :: Scale OffWheel
dScale = Scale
  { scaleName = "D"
  , scaleFun  = logBase 10
  , scaleFun' = (10**)
  }

aScale :: Scale OffWheel
aScale = Scale
  { scaleName = "A"
  , scaleFun  = logBase 100
  , scaleFun' = (100**)
  }

bScale :: Scale OnWheel
bScale = Scale
  { scaleName = "B"
  , scaleFun  = logBase 100
  , scaleFun' = (100**)
  }

kScale :: Scale OffWheel
kScale = Scale
  { scaleName = "K"
  , scaleFun  = logBase 1000
  , scaleFun' = (1000**)
  }

llScale :: Int -> Scale pos
llScale n  = Scale
  { scaleName = "LL" ++ show n
  , scaleFun  = subtract off . logBase 10 . log
  , scaleFun' = exp . (10**) . (+off)
  }
  where
  off = fromIntegral n - 3

ll3Scale :: Scale OffWheel
ll3Scale = llScale 3

ll2Scale :: Scale OffWheel
ll2Scale = llScale 2

sScale :: Scale OnWheel
sScale = Scale
  { scaleName = "S"
  , scaleFun  = (+1) . logBase 10 . sin . degToRad
  , scaleFun' = radToDeg . asin . (10**) . subtract 1
  }

stScale :: Scale OnWheel
stScale = Scale
  { scaleName = "ST"
  , scaleFun  = (+2) . logBase 10 . sin . degToRad
  , scaleFun' = radToDeg . asin . (10**) . subtract 2
  }

t1Scale :: Scale OnWheel
t1Scale = Scale
  { scaleName = "T1"
  , scaleFun  = (+1) . logBase 10 . tan . degToRad
  , scaleFun' = radToDeg . atan . (10**) . subtract 1
  }

t2Scale :: Scale OnWheel
t2Scale = Scale
  { scaleName = "T2"
  , scaleFun  = logBase 10 . tan . degToRad
  , scaleFun' = radToDeg . atan . (10**)
  }

degToRad :: Double -> Double
degToRad x = x * pi / 180

radToDeg :: Double -> Double
radToDeg x = x * 180 / pi

getCursorPos :: SlideRule Double
getCursorPos = SlideRule (gets slideCursor)

getWheelPos :: SlideRule Double
getWheelPos = SlideRule (gets slideWheel)

setCursorPos :: Double -> SlideRule ()
setCursorPos x = SlideRule (modify (\s -> s { slideCursor = x }))

setWheelPos :: Double -> SlideRule ()
setWheelPos x = SlideRule (modify (\s -> s { slideWheel = x }))

mark :: IsOnWheel pos => Scale pos -> Double -> SlideRule ()
mark scale value

  | scaleWheel scale = do w <- getWheelPos
                          setCursorPos (mod' (w+frac) 1)

  | otherwise        = do setCursorPos frac
  where
  frac = scaleFun scale value

readCursor :: IsOnWheel pos => Scale pos -> SlideRule Double
readCursor scale = do
  c <- getCursorPos
  w <- if scaleWheel scale then getWheelPos else return 0
  let c' = mod' (c-w) 1
  return (scaleFun' scale c')

move :: Scale OnWheel -> Double -> SlideRule ()
move scale value =
  do c <- getCursorPos
     let v = scaleFun scale value
     setWheelPos (mod' (c - v) 1)

multiply :: Double -> Double -> String
multiply x y = printAnswer $
  do mark dScale  x
     move  ciScale y
     mark ciScale 1
     return dScale

fourthPowCIK :: Double -> String
fourthPowCIK x = printAnswer $
  do mark kScale x
     move ciScale x
     mark ciScale 1
     return kScale

fourthPowCCIA :: Double -> String
fourthPowCCIA x = printAnswer $
  do move ciScale x
     mark cScale x
     return aScale