diff --git a/.gitignore b/.gitignore index 18be007..8cffd9e 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ .*.swp /dist +/dist-newstyle \ No newline at end of file diff --git a/slide-dsl.cabal b/slide-dsl.cabal index 969c892..4dc3bae 100644 --- a/slide-dsl.cabal +++ b/slide-dsl.cabal @@ -1,11 +1,9 @@ --- Initial slide-dsl.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - +cabal-version: 3.0 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, diff --git a/src/Scales.hs b/src/Scales.hs new file mode 100644 index 0000000..53787d7 --- /dev/null +++ b/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 diff --git a/src/SlideRule.hs b/src/SlideRule.hs index 1784687..5c913a2 100644 --- a/src/SlideRule.hs +++ b/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 s = showFFloat (Just 3) (runSlideRule (readCursor =<< s)) "" +printAnswer :: SlideRule Double -> String +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 + , scaleFun :: Double -> Double -- ^ scale domain -> position + , scaleFun' :: Double -> Double -- ^ position -> scale domain } -cScale :: Scale OnWheel -cScale = Scale - { scaleName = "C" - , scaleFun = logBase 10 - , scaleFun' = (10**) +invertScale :: String -> Scale x -> Scale y +invertScale n s = Scale + { scaleName = n + , scaleFun = \x -> 1 - scaleFun s x -- mod' _ 1? + , 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 })) - -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 +setWheelPos x = SlideRule (modify (\s -> s { slideWheel = mod' x 1 })) 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 () -move scale value = - do c <- getCursorPos - let v = scaleFun scale value - setWheelPos (mod' (c - v) 1) +readAt :: (IsOnWheel a, IsOnWheel b) => Scale a -> Double -> Scale b -> SlideRule Double +readAt refScale refValue outScale = + do x <- correction (scaleFun refScale refValue) + pure (scaleFun' outScale x) + 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 +-}