nano-ui-sdl-0.1.0.0: examples/SdlAnim.hs
module Main (main) where
import Control.Monad (forM_, when)
import NanoUI
import NanoUI.Backend.Sdl (SdlOptions (..), defaultSdlOptions, runSdlApp)
import qualified Data.Text as T
import Text.Printf (printf)
main :: IO ()
main =
runSdlApp
defaultSdlOptions
{ sdlAppTheme = Just benchTheme
, sdlAppShouldQuit = \inp -> inputKeysElem KeyEscape (inputKeys inp)
}
animUi
-- Steenbeck flatbed: putty Formica, black 16mm path, cream frame, ruby rec.
benchTheme :: Theme
benchTheme =
let plate =
Style
{ styleBg = colorRGBA 214 208 196 255
, styleFg = colorRGBA 28 26 22 255
, styleBorder = colorRGBA 92 86 76 255
, styleBorderWidth = 1
, styleCornerRadius = 1
, styleHoverBg = colorRGBA 222 216 204 255
, styleActiveBg = colorRGBA 196 190 178 255
}
in defaultTheme
{ themeWindow = formica
, themePanel = plate
, themeFloatingWindow = plate
, themeButton =
Style
{ styleBg = colorRGBA 196 190 176 255
, styleFg = colorRGBA 28 26 22 255
, styleBorder = colorRGBA 74 68 58 255
, styleBorderWidth = 1
, styleCornerRadius = 1
, styleHoverBg = colorRGBA 228 222 208 255
, styleActiveBg = colorRGBA 168 162 148 255
}
, themeInput =
Style
{ styleBg = colorRGBA 176 170 156 255
, styleFg = colorRGBA 28 26 22 255
, styleBorder = colorRGBA 74 68 58 255
, styleBorderWidth = 1
, styleCornerRadius = 1
, styleHoverBg = colorRGBA 186 180 166 255
, styleActiveBg = colorRGBA 158 152 138 255
}
, themeSeparator = colorRGBA 92 86 76 255
, themeAccent = ruby
, themeMuted = colorRGBA 90 84 74 255
, themeOverlayDim = colorRGBA 40 36 30 160
}
formica, film, paper, ruby, lamp, punch :: Color
formica = colorRGBA 184 176 162 255
film = colorRGBA 18 16 14 255
paper = colorRGBA 244 236 220 255
ruby = colorRGBA 154 42 36 255
lamp = colorRGBA 255 196 92 255
punch = colorRGBA 232 224 208 255
animUi :: NanoUI ()
animUi = do
(exposed, setExposed) <- useFlag False
(rewinding, setRewinding) <- useFlag False
(lampOn, setLamp) <- useFlag False
(bellowsOpen, setBellows) <- useFlag False
(tossed, setTossed) <- useFlag False
(stiffSpring, setStiffSpring) <- useFlag False
(throwRaw, setThrowRaw) <- useFloat 75
tossT <-
withKey ("toss" :: String)
( animateTo
(Spring (if stiffSpring then presetStiff else presetBouncy))
(if tossed then 1 else 0)
)
lampT <-
if lampOn
then withKey ("lamp" :: String) (animate (Tween EaseInOutCubic 1.6 0) 0 1)
else pure 0
wash <-
withKey ("wash" :: String) (animateTo (Tween EaseInOutCubic 0.85 0) (if lampOn then 1 else 0))
bellowsT <-
withKey ("bellows" :: String) (animateTo (Tween EaseOutCubic 0.45 0) (if bellowsOpen then 1 else 0))
clock <-
if exposed
then withKey ("clock" :: String) (animate (Tween EaseLinear 3.2 0) 0 1)
else
if rewinding
then withKey ("clock" :: String) (animateTo (Tween EaseLinear 0.35 0) 0)
else pure 0
let frames = floor (clock * 128) :: Int
footage = T.pack (printf "%d+%02d" (frames `div` 16) (frames `mod` 16))
lampGlow = sin (lampT * pi)
scrollWith (tight . grow) $
columnWith (padAll 28 . gap 18 . fillW) $ do
rowWith (tight . gap 10 . alignMid . fillW) $ do
heading "16mm"
flex
withKey ("footage" :: String) (muted footage)
rowWith (tight . gap 8 . alignMid . fillW) $ do
whenM (button "Expose") (setExposed True >> setRewinding False)
whenM (button "Rewind") (setExposed False >> setRewinding True)
whenM (button (if lampOn then "Lamp off" else "Lamp on")) (setLamp (not lampOn))
flex
whenM (button (if tossed then "Catch" else "Toss")) (setTossed (not tossed))
whenM (button (if stiffSpring then "Stiff" else "Bouncy")) (setStiffSpring (not stiffSpring))
throwSec <- do
label "Throw"
newThrow <- slider 35 140 throwRaw
setThrowRaw newThrow
pure (newThrow / 100)
cycleThrow <- lockThrow exposed throwSec
let cycleLen = pullCycleLen cycleThrow
pullPhase <-
if exposed
then withKey ("pulldown" :: String) (animate (Tween EaseLinear cycleLen 0) 0 1)
else pure 0
let time = pullPhase * cycleLen
tossRail tossT
laneTs <- transport exposed rewinding cycleThrow time wash lampGlow
when
(rewinding && not exposed && abs clock < 0.001 && all settled laneTs)
(setRewinding False)
panelWith (padXY 12 10 . gap 8 . fixedW (220 + 180 * bellowsT)) $ do
rowWith (tight . gap 10 . alignMid . fillW) $ do
whenM
(button (if bellowsOpen then "Collapse" else "Extend"))
(setBellows (not bellowsOpen))
flex
let iris = 12 + 22 * bellowsT
irisCol = lerpColor film (lerpColor paper ruby 0.18) bellowsT
box (fixedWH iris iris) irisCol
settled :: Float -> Bool
settled x = abs x < 0.001
lockThrow :: Bool -> Float -> NanoUI Float
lockThrow exposed throwSec =
withKey ("cycleThrow" :: String) $
if exposed
then pure throwSec
else animateTo (Tween EaseLinear 0.35 0) 0 >> pure throwSec
transport :: Bool -> Bool -> Float -> Float -> Float -> Float -> NanoUI [Float]
transport exposed rewinding throwSec time wash glow = do
let washCol = lerpColor film lamp (wash * (0.45 + 0.55 * glow))
columnWith (tight . gap 0 . fillW) $ do
perfs
withKey ("washTop" :: String) (box (fixedH 10 . fillW) washCol)
ts <-
columnWith (padXY 0 10 . gap 10 . fillW) $
sequence
[ lane exposed rewinding throwSec time "Leader" EaseLinear
, lane exposed rewinding throwSec time "Gate" EaseInCubic
, lane exposed rewinding throwSec time "Shuttle" EaseOutCubic
, lane exposed rewinding throwSec time "Reg" EaseInOutCubic
, lane exposed rewinding throwSec time "Claw" EaseOutBack
, lane exposed rewinding throwSec time "Bezier" (EaseCubicBezier 0.33 0 0.2 1)
]
withKey ("washBot" :: String) (box (fixedH 10 . fillW) washCol)
perfs
pure ts
perfs :: NanoUI ()
perfs =
rowWith (tight . gap 0 . alignMid . fillW) $ do
withKey ("perfL" :: String) (box (fixedWH 12 18) film)
forM_ [0 .. 16 :: Int] $ \i ->
withKey i $ do
box (fixedWH 6 18) film
box (fixedWH 7 6) punch
box (fixedWH 3 18) film
withKey ("perfR" :: String) (box (fillW . fixedH 18) film)
pullHoldSec :: Float
pullHoldSec = 1
pullCycleLen :: Float -> Float
pullCycleLen throwSec = 3 * pullHoldSec + 2 * throwSec
laneT :: Ease -> Float -> Float -> Float
laneT ease throwSec time =
let hold = pullHoldSec
out0 = hold
out1 = out0 + throwSec
topHold1 = out1 + hold
in0 = topHold1
in1 = in0 + throwSec
in if time < out0
then 0
else if time < out1
then applyEase ease ((time - out0) / throwSec)
else if time < in0
then 1
else if time < in1
then 1 - applyEase ease ((time - in0) / throwSec)
else 0
tossRail :: Float -> NanoUI ()
tossRail t = trackRow "Spring" t ruby
lane :: Bool -> Bool -> Float -> Float -> T.Text -> Ease -> NanoUI Float
lane exposed rewinding throwSec time name ease = do
t <-
if exposed
then pure (laneT ease throwSec time)
else
if rewinding
then withKey name (animateTo (Tween ease throwSec 0) 0)
else pure 0
trackRow name t paper
pure t
trackRow :: T.Text -> Float -> Color -> NanoUI ()
trackRow name t shuttle =
withKey name $
rowWith (tight . gap 12 . alignMid . fillW) $ do
labelWith (tight . fixedW 72) name
columnWith (tight . gap 0 . fillW) $ do
let travel = 394.0 :: Float
rowWith (tight . alignMid . fillW) $ do
box (fixedWH 4 22) film
spacer (Fixed (max 0 (t * travel))) Fit
box (fixedWH 16 16) shuttle
flex
box (fixedWH 4 22) film