Sprite editor in PureScript (for use with try-thermite)

Main.purs

module Main where

import Prelude

import Data.Array
import Data.Foldable
import Data.Traversable (for)
import Data.Maybe
import Data.Int (toNumber)
import React as R
import React (ReactElement)
import React.DOM as R
import React.DOM (text, div, h1, p, a, pre)
import React.DOM.Props as RP
import React.DOM.Props (href)
import React.DOM.Props (style, onClick, target)
import Thermite hiding (defaultMain) as T
import Thermite.Try as T

initialState = 
  { msg: "Please click on pixels to toggle them."
  , sprite: chameleonBitmap
  }

chameleonBitmap :: Array Boolean
chameleonBitmap = 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
  ]

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 dispatch = do
  mapWithIndex (pixyP dispatch (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

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

pixy :: _ -> XY -> Boolean -> Pixel
pixy dispatch {x, y} b =
  pixyP dispatch (colorize green) {x,y} b

pixyP :: forall p. _ -> (p -> Color) -> XY -> p -> Pixel
pixyP dispatch colorize {x, y} p =
  div [ style { background: colorize p
              , top:        show (y*dy) <> "px"
              , left:       show (x*dx) <> "px"
              , width:      show dx     <> "px"
              , height:     show dy     <> "px"
              , position:   "absolute"
              }
      , onClick (\e -> dispatch (TogglePixel {x:x, y:y}))
      ] []
  where
    dx = 20
    dy = 20

type Color = String
red   = "red"
green = "lightgreen"
black = "black"

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

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

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

data EditAction = TogglePixel XY

type State = { msg :: String, sprite :: Sprite Boolean }

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

render :: T.Render State _ _
render dispatch _ state _ =
  [ h1  [] [ text "Sprite editor" ]
  , p   [] [ text "Inspired by the lovely Commodore 64. (c) 2017 by Erik of "
           , a [ href "http://www.shinsetsu.nl", target "_top" ] [ text "Shinsetsu" ]
           , text "."
           ]
  , p   [] [ text state.msg ]
  , div [ style { position: "relative", height: "450px" } ]
        (renderSprite dispatch state.sprite)
  , pre [ style { style: "border: 1px solid red" } ]
        [ text <<< fold <<< mapWithIndex (columnize 3) <<< renderBytes $ state.sprite ]
  ] 

main = T.defaultMain spec initialState

performAction :: T.PerformAction _ State _ EditAction
performAction (TogglePixel xy@{x,y}) _ _ = void <<< T.modifyState $ 
  \state -> state { msg = "toggle pixel (" <> show x <> "," <> show y <>")"
                  , sprite = state.sprite `updateSpriteAt` xy
                  }
  where
    updateSpriteAt spr {x,y} = fromMaybe spr $ modifyAt (xyToIndex widthC64 x y) not spr

spec :: T.Spec _ State _ EditAction
spec = T.simpleSpec performAction render