glguy/slide-dsl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Update the primitives, extract example scales

Browse Source
This commit is contained in:
Eric Mertens 2024-06-10 20:34:29 -07:00
parent dd74a783aa
commit f8b35a57e0
4 changed files with 175 additions and 121 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

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

13
slide-dsl.cabal
View File

@ -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,

91
src/Scales.hs Normal file
View File

@ -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

191
src/SlideRule.hs
View File

@ -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
-}