Sprite editor in PureScript (for use with TryPurescript + 'behaviors' backend)

Main.purs

module Main where

import Prelude

import Color (Color(..), black, white, lighten)
import Color.Scheme.MaterialDesign (blueGrey, green, red, yellow)
import Control.Monad.Eff (Eff(..))
import Data.Array ((..), cons, take, drop, mapWithIndex, length, index)
import Data.Foldable (class Foldable, foldMap, fold)
import Data.Int (toNumber, ceil, round, floor)
import Data.List.Lazy as List
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Traversable (traverse)
import FRP (FRP)
import FRP.Event (Event(..))
import FRP.Event.Time as Event
import FRP.Behavior as Behavior
import FRP.Behavior (Behavior, fixB, integral')
import FRP.Behavior.Mouse as Mouse
import FRP.Behavior.Time as Time
import FRP.Try (defaultMain)
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, scale, translate)
import Graphics.Canvas (CANVAS)
 
chameleonBitmap0 :: Array Boolean
chameleonBitmap0 = map truncateToBoolean
  [ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,0,0,0,1,1,1,0,0,0
  , 0,1,1,1,0,0,0,0,1,1,1,1,1,1,1,1,1,0,1,1,1,1,0,0
  , 1,1,0,0,1,0,0,1,1,1,1,1,1,1,1,1,1,1,1,0,1,1,1,0
  , 1,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0
  , 1,1,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,0,0,0,1
  , 0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,1,1,1
  , 0,0,0,0,0,0,1,1,1,0,1,1,1,1,0,1,1,1,0,1,1,1,0,0
  , 0,0,0,0,0,1,1,0,0,1,0,0,0,0,1,0,0,1,0,0,0,0,0,0
  , 0,0,0,0,1,1,0,0,0,0,1,0,0,0,1,0,0,0,1,1,1,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  ]

chameleonBitmap1 :: Array Boolean
chameleonBitmap1 = map truncateToBoolean
  [ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,0,0,0,1,1,1,0,0,0
  , 0,1,1,1,0,0,0,0,1,1,1,1,1,1,1,1,1,0,1,1,1,1,0,0
  , 1,1,0,0,1,0,0,1,1,1,1,1,1,1,1,1,1,1,1,0,1,1,1,0
  , 1,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0
  , 1,1,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,0,0,0,1
  , 0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,1,1,1
  , 0,0,0,0,0,0,1,1,1,0,1,1,1,1,0,1,1,1,0,1,1,1,0,0
  , 0,0,0,0,0,0,1,0,0,1,0,0,0,0,1,0,0,1,0,0,0,0,0,0
  , 0,0,0,0,0,1,1,0,0,0,1,0,0,0,1,0,0,0,1,1,1,0,0,0
  , 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  ]

truncateToBoolean :: Int -> Boolean
truncateToBoolean 0 = false
truncateToBoolean _ = true

colorize :: Color -> Boolean -> Color 
colorize _ false = black
colorize c true  = c

indexToXY :: X -> Int -> XY
indexToXY width i = { x: i `mod` width, y: i/width }

xyToIndex :: X -> X -> Y -> Int
xyToIndex width x y = y*width + x

renderSprite :: Sprite Boolean -> Sprite Pixel
renderSprite = do
  mapWithIndex (pixy (colorize green) <<< indexToXY widthC64)

widthC64 = 3*8

-- TODO ghastly recursion, needs sliding window
renderBytes :: Sprite Boolean -> Array String
renderBytes []   = []
renderBytes bits = byteStr `cons` renderBytes rest
  where
    byteStr = foldMap (if _ then "1" else "0") byte
    byte    = take 8 bits
    rest    = drop 8 bits

columnize :: forall a b. Int -> Int -> String -> String
columnize columns column s = "%" <> s <> if shouldWrap then ",\n" else ", "
  where shouldWrap = (column + 1) `mod` columns == 0

----------------------------------------------------------------------------

-- TODO param order; xy last?
pixy :: forall p. (p -> Color) -> XY -> p -> Pixel
pixy colorize {x, y} p =
  scale 2.0 2.0 <<<
  translate ((1.0 + toNumber x) * dx) ((1.0 + toNumber y) * dy) <<<
  scale dx dy $
  filled (fillColor (colorize p))
         (rectangle (-1.0) (-1.0) 1.0 1.0)
  where
    dx = 5.0
    dy = 5.0

type X = Int
type Y = Int
type XY = { x :: X, y :: Y }

-- | p is the pixel type
type Sprite p = Array p

type Pixel = Drawing

----------------------------------------------------------------------------

main :: forall e. Eff (frp :: FRP, canvas :: CANVAS | e) Unit
main = defaultMain (scene {w: 800.0, h:600.0})

scene :: {w :: Number, h :: Number} -> Behavior Drawing 
scene {w, h} =
  (drawSprite <<< indexMod chameleonBitmap0 chameleonBitmaps <<< round <$> seconds)
  <> ((\t -> pixy (colorize yellow) {x: 23-(round (t/2.0) `mod` 24), y: 2} true) <$> seconds)
  where
  drawSprite :: Array Boolean -> Drawing
  drawSprite = fold <<< renderSprite

  indexMod zero xs i = fromMaybe zero $ xs `index` (i `mod` (length xs))
  chameleonBitmaps = [chameleonBitmap0, chameleonBitmap1]

seconds :: Behavior Number
seconds = map ((_ / 701.0) <<< toNumber) Time.millisSinceEpoch