Update the primitives, extract example scales

.gitignore

@@ -1,2 +1,3 @@
 .*.swp
 /dist
+/dist-newstyle

slide-dsl.cabal

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

src/Scales.hs

@@ -0,0 +1,91 @@
+{-# Language DataKinds #-}
+module Scales where
+
+import SlideRule
+
+cScale :: Scale OnWheel
+cScale = Scale
+  { scaleName = "C"
+  , scaleFun  = logBase 10
+  , scaleFun' = (10**)
+  }
+
+ciScale :: Scale OnWheel
+ciScale = invertScale "CI" cScale
+
+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

src/SlideRule.hs

@@ -1,7 +1,23 @@
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE DataKinds #-}
-module SlideRule where
+module SlideRule (
+  SlideRule,
+  Scale(..),
+  ScalePosition(..),
+  invertScale,
+
+  mark,
+  align,
+  turn,
+
+  readCursor,
+  readAt,
+
+  runSlideRule,
+  printAnswer,
+  
+) where
 
 import Control.Applicative
 import Control.Monad.Trans.State
@@ -25,116 +41,36 @@ initialState = SlideState
 runSlideRule :: SlideRule a -> a
 runSlideRule (SlideRule m) = evalState m initialState
 
-printAnswer :: IsOnWheel pos => SlideRule (Scale pos) -> String
+printAnswer :: SlideRule Double -> String
-printAnswer s = showFFloat (Just 3) (runSlideRule (readCursor =<< s)) ""
+printAnswer s = showFFloat (Just 3) (runSlideRule s) ""
 
 instance Show a => Show (SlideRule a) where
   show = show . runSlideRule
 
 data ScalePosition = OnWheel | OffWheel
 
-class    IsOnWheel (pos :: ScalePosition) where
+class IsOnWheel (pos :: ScalePosition) where
   scaleWheel :: scale pos -> Bool
-instance IsOnWheel OnWheel  where scaleWheel _ = True
+
-instance IsOnWheel OffWheel where scaleWheel _ = False
+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 -- ^ scale domain -> position
-  , scaleFun' :: Double -> Double
+  , scaleFun' :: Double -> Double -- ^ position -> scale domain
   }
 
-cScale :: Scale OnWheel
+invertScale :: String -> Scale x -> Scale y
-cScale = Scale
+invertScale n s = Scale
-  { scaleName = "C"
+  { scaleName = n
-  , scaleFun  = logBase 10
+  , scaleFun  = \x -> 1 - scaleFun s x -- mod' _ 1?
-  , scaleFun' = (10**)
+  , scaleFun' = \x -> scaleFun' s (1-x)
   }
 
-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)
 
@@ -142,20 +78,10 @@ getWheelPos :: SlideRule Double
 getWheelPos = SlideRule (gets slideWheel)
 
 setCursorPos :: Double -> SlideRule ()
-setCursorPos x = SlideRule (modify (\s -> s { slideCursor = x }))
+setCursorPos x = SlideRule (modify (\s -> s { slideCursor = mod' x 1 }))
 
 setWheelPos :: Double -> SlideRule ()
-setWheelPos x = SlideRule (modify (\s -> s { slideWheel = x }))
+setWheelPos x = SlideRule (modify (\s -> s { slideWheel = mod' x 1 }))
-
-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
@@ -164,12 +90,48 @@ readCursor scale = do
   let c' = mod' (c-w) 1
   return (scaleFun' scale c')
 
-move :: Scale OnWheel -> Double -> SlideRule ()
+readAt :: (IsOnWheel a, IsOnWheel b) => Scale a -> Double -> Scale b -> SlideRule Double
-move scale value =
+readAt refScale refValue outScale =
-  do c <- getCursorPos
+ do x <- correction (scaleFun refScale refValue)
-     let v = scaleFun scale value
+    pure (scaleFun' outScale x)
-     setWheelPos (mod' (c - v) 1)
+  where
+    correction x
+      | scaleWheel refScale, not (scaleWheel outScale) =
+        do p <- getWheelPos
+           pure (mod' (x+p) 1)
+      | not (scaleWheel refScale), scaleWheel outScale =
+        do p <- getWheelPos
+           pure (mod' (x-p) 1)
+      | otherwise = pure x
 
+-- | Set the cursor to the value on the given scale
+mark :: IsOnWheel pos => Scale pos -> Double -> SlideRule ()
+mark scale value
+
+  | scaleWheel scale = do w <- getWheelPos
+                          setCursorPos (w + frac)
+
+  | otherwise        = setCursorPos frac
+  where
+  frac = scaleFun scale value
+
+-- | Turn the wheel to align a value on the wheel with a value off the wheel.
+align :: Scale OffWheel -> Double -> Scale OnWheel -> Double -> SlideRule ()
+align offScale offValue onScale onValue =
+  setWheelPos (scaleFun offScale offValue - scaleFun onScale onValue)
+
+-- | Turn the wheel so that a scale on the wheel has a specific value
+-- on the cursor.
+turn :: Scale OnWheel -> Double -> SlideRule ()
+turn scale value =
+ do c <- getCursorPos
+    let v = scaleFun scale value
+    setWheelPos (c - v)
+
+resetWheel :: SlideRule ()
+resetWheel = setWheelPos 0
+
+{-
 multiply :: Double -> Double -> String
 multiply x y = printAnswer $
   do mark dScale  x
@@ -189,3 +151,4 @@ fourthPowCCIA x = printAnswer $
   do move ciScale x
      mark cScale x
      return aScale
+-}