Back squat model using purescript's flare library

Main.purs

module Main where

import Prelude

import Control.Monad.Eff (Eff)

import Data.List (List(..), (:), fromFoldable)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap, over, over2)
import Data.Ord (abs)

import DOM (DOM)
import Flare (UI, numberSlider)
import Flare.Drawing (Point, Drawing, path, outlined, lineWidth, runFlareDrawing)
import Graphics.Canvas (CANVAS)
import Math (pi, cos, sin, acos)
import Signal.Channel (CHANNEL)

newtype Metres  = Metres Number
newtype Radians = Radians Number
newtype Degrees = Degrees Number

derive instance newtypeMetres  :: Newtype Metres _
derive instance newtypeRadians :: Newtype Radians _
derive instance newtypeDegrees :: Newtype Degrees _

toRadians :: Degrees -> Radians
toRadians (Degrees n) = Radians (n * pi / 180.0)

type Joint = Point

type Inputs
    = { shankLen :: Metres
      , femurLen :: Metres
      , trunkLen :: Metres
      , ankleExt :: Degrees
      , kneeExt  :: Degrees
      }

drawSquatter:: Inputs -> List Point
drawSquatter { shankLen, femurLen, trunkLen, ankleExt, kneeExt }
    = fromFoldable [ toe, ankle, knee, hip, shoulder ]
    where
        -- Guestimate that the foot is ~40% of the shank length.
        footLen :: Metres
        footLen =
            over Metres (0.4 * _) shankLen

        toe :: Joint
        toe =
            { x: unwrap footLen
            , y: 0.0
            }

        -- NOTE: ankle sits on the origin.
        ankle :: Joint
        ankle =
            { x: 0.0
            , y: 0.0
            }

        ankleAngle :: Radians
        ankleAngle =
            toRadians ankleExt

        knee :: Joint
        knee =
            { x: unwrap shankLen * cos (unwrap ankleAngle)
            , y: unwrap shankLen * sin (unwrap ankleAngle)
            }

        kneeAngle :: Radians
        kneeAngle =
            toRadians kneeExt

        kneeAngle' :: Radians  -- prime denotes from horizontal
        kneeAngle' =
            over2 Radians (-) kneeAngle ankleAngle

        hip :: Joint
        hip =
            { x: knee.x - unwrap femurLen * cos (unwrap kneeAngle')
            , y: knee.y - unwrap femurLen * sin (unwrap kneeAngle')
            }

        hipAngle' :: Radians
        hipAngle' =
            Radians $ acos (negate hip.x / unwrap trunkLen)

        hipAngle :: Radians
        hipAngle =
            over2 Radians (+) hipAngle' kneeAngle'

        -- barbell ~ shoulder
        shoulder :: Joint
        shoulder =
            { x: ankle.x   -- must stay over the heel
            , y: hip.y + (unwrap trunkLen) * sin (unwrap hipAngle')
            }

preparePoints :: List Point -> List Point
preparePoints = absFlip <<< scaleUp
    where
        scaleUp :: List Point -> List Point
        scaleUp = map \pt -> pt { x = pt.x * 100.0, y = pt.y * 100.0 }

        absFlip :: List Point -> List Point
        absFlip pts =
            case findCoords max pts of
                Just { x: xMax, y: yMax } ->
                    (\{ x, y } -> { x: abs $ x - xMax, y: abs $ y - yMax }) <$> pts
                Nothing ->
                    pts

        findCoords :: (Number -> Number -> Number) -> List Point -> Maybe Point
        findCoords _ Nil = Nothing
        findCoords f (head:pts) = go head pts
            where go accum Nil = Just accum
                  go accum (pt:rest) = go { x: f accum.x pt.x
                                          , y: f accum.y pt.y} rest

render :: Number -> Number -> Drawing
render kneeExt ankleExt =
    outlined (lineWidth 2.0) <<< path <<< preparePoints $ joints
    where
        joints :: List Point
        joints = drawSquatter { shankLen: Metres 1.0
                              , femurLen: Metres 1.0
                              , trunkLen: Metres 1.5
                              , ankleExt: Degrees ankleExt
                              , kneeExt:  Degrees kneeExt
                              }

flare :: forall eff. UI eff Drawing
flare = render
    <$> numberSlider "Knee Extension"  0.0 180.0 1.0 0.0
    <*> numberSlider "Ankle Extension" 40.0 90.0 1.0 89.0

main :: forall e. Eff (dom :: DOM, channel :: CHANNEL, canvas :: CANVAS | e) Unit
main = runFlareDrawing "controls" "canvas" flare