initial commit

.gitignore

@@ -0,0 +1,2 @@
+.*.swp
+/dist

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2015, Eric Mertens
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Eric Mertens nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

slide-dsl.cabal

@@ -0,0 +1,23 @@
+-- Initial slide-dsl.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                slide-dsl
+version:             0.1.0.0
+-- synopsis:            
+-- description:         
+license:             BSD3
+license-file:        LICENSE
+author:              Eric Mertens
+maintainer:          emertens@gmail.com
+-- copyright:           
+category:            Math
+build-type:          Simple
+-- extra-source-files:  
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     SlideRule
+  other-extensions:    GeneralizedNewtypeDeriving
+  build-depends:       base >=4.7 && <4.8, transformers >=0.3 && <0.4
+  hs-source-dirs:      src
+  default-language:    Haskell2010

src/SlideRule.hs

@@ -0,0 +1,191 @@
+{-# 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