Update the primitives, extract example scales
This commit is contained in:
parent
dd74a783aa
commit
f8b35a57e0
1
.gitignore
vendored
1
.gitignore
vendored
|
|
@ -1,2 +1,3 @@
|
|||
.*.swp
|
||||
/dist
|
||||
/dist-newstyle
|
||||
|
|
@ -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
91
src/Scales.hs
Normal 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
191
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
|
||||
-}
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user