15 Shades of Grey

Arrange the grey squares so they appear from brightest to darkest going left to right, top to bottom.

We write code that works with the vanilla GHC compiler, the Haste compiler, and the Asterius compiler.

Haste provides a library for common front-end tasks such as interacting with the HTML DOM, drawing on a canvas, and handling events:

#ifdef __HASTE__
import Data.IORef
import Data.List
import Control.Monad
import Haste
import Haste.DOM
import Haste.Events
import Haste.Graphics.Canvas

Asterius is more Spartan:

import Data.IORef
import Data.List
import Control.Monad
import Asterius.Types

The pure part of our code shuffles the board until we find a solvable 15-puzzle position.

We ought to use uniformR instead of randomR but we’re supporting older compilers.

For picking a random permutation uniformly, we could import System.Random.Shuffle, but instead we implement our own to illustrate a point. The typical imperative solution repeatedly swaps memory contents chosen from certain ranges and runs in linear time. Although pure code is forbidden from such swaps, we can replace an array of memory cells with a Data.Map that maps memory indexes to data contents. This sort of thing is based on trees, thus the running time increases by a logarithmic factor.

Thus in general, we can construct a persistent version of a data structure by paying at most a logarithmic factor.

Hopefully it is clear our shuffling routine has \(O(N \log N)\) complexity. This matches System.Random.Shuffle, but likely has a far higher constant factor because a Data.Map is intended for more than just shuffling.

On a related note, a C programmer would represent a 2D board with an array. A straightforward translation to Haskell is inefficient, because any array update creates a fresh copy of the entire array. Better to use a map; to update a map of \(N\) entries only costs \(O(\log N)\) more space.

import qualified Data.Map.Strict as M
import Data.Map.Strict (Map, (!))
import System.Random

type Board = Map (Int, Int) Int

shuf m g = M.fromList $ zip (M.keys m) $ shufElems m g
shufElems m g = case M.size m of
  0 -> []
  n -> let
    (i, g') = randomR (0, n - 1) g
    (_, v) = M.elemAt i m
    in v : shufElems (M.deleteAt i m) g'

side = 4
hole = side^2

goal = M.fromList $ zip ((,) <$> [0..side-1] <*> [0..side-1]) [1..]

parity []     = 0
parity (x:xs) = length (filter (x>) xs) + parity xs
              + if x == hole then uncurry (+) $ divMod (length xs) side else 0

gen :: IO Board
gen = do
  z <- shuf goal <$> newStdGen
  if even $ parity $ M.elems z then pure z else gen

Most of the code is taken by the front end, especially since we’re animating tiles. For Asterius, we define wrappers for JavaScript functions, including some we wrote that can be studied by viewing the source of this page.

foreign import javascript "fillrect($1,$2,$3,$4,$5,$6)" fillrect :: JSVal -> Int -> Int -> Int -> Int -> JSString -> IO ()
foreign import javascript "setKeydown($1)" js_onKeyDown :: JSFunction -> IO ()
foreign import javascript "document.getElementById($1).onmousedown=$2" js_onMouseDown :: JSString -> JSFunction -> IO ()
foreign import javascript "document.getElementById($1).innerText=$2" js_setInner :: JSString -> JSString -> IO ()
foreign import javascript "$1.keyCode" keyCode :: JSVal -> Int
foreign import javascript "$1.offsetX" offsetX :: JSVal -> Int
foreign import javascript "$1.offsetY" offsetY :: JSVal -> Int
foreign import javascript "wrapper" mkCallback :: IO () -> IO JSFunction
foreign import javascript "wrapper" mkCallback1 :: (JSVal -> IO ()) -> IO JSFunction
foreign import javascript "wrapper oneshot" mkOnceCallback :: IO () -> IO JSFunction
foreign import javascript "setTimeout($1,$2)" js_setTimeout :: JSFunction -> Int -> IO ()
foreign import javascript "document.getElementById('canvas').getContext('2d')" mustCanvas :: IO JSVal

rgb r g b = toJSString $ concat ["rgb(", show r, ",", show g, ",", show b, ")"]
delayCall n f = flip js_setTimeout n =<< mkOnceCallback f
onKeyDown f = js_onKeyDown =<< mkCallback1 f
onMouseDown s f = js_onMouseDown (toJSString s) =<< mkCallback1 f
setInner elemId s = js_setInner (toJSString elemId) (toJSString s)

The Haste equivalents use the library functions bundled with the compiler:

#ifdef __HASTE__
delayCall n f = void $ setTimer (Once n) f
rgb = RGB
onKeyDown f = void $ onEvent documentBody KeyDown f
onMouseDown s f = do
  Just e <- elemById s
  void $ onEvent e MouseDown f
setInner elemId s = do
  Just e <- elemById elemId
  setProp e "innerText" s
offsetX = fst . mouseCoords
offsetY = snd . mouseCoords
fillrect canvas x y w h c = let f = fromIntegral in
  renderOnTop canvas $ color c $ fill $ rect (f x, f y) (f $ x + w, f $ y + h)
mustCanvas = maybe undefined id <$> getCanvasById "canvas"

The rest of the code is the same for Haste and Asterius except for a preventDefault call. The Haste edition prevents the default effect of key down events if they are valid moves, so the browser behaves mostly as usual during play and entirely as usual after winning.

With Asterius, calling preventDefault() from our code is difficult because JavaScript and WebAssembly call one another, and events are handled in between; by the time we call preventDefault() it is too late. We work around this with a JavaScript helper eats key events in a certain focusable div element before ceding control to wasm.

The user might have to click in a particular area to use the keys, and must click outside in order to use typcial shortcuts such as Ctrl-R. To mimic our Haste code, we could perhaps preventDefault for all key events on the document body then somehow generate events that we want to pass on.

We mostly redraw only the two tiles affected by the animation. However, if a move is interrupted by another move before its animation is complete, we redraw the whole board before starting the new animation.

#if defined(ASTERIUS) || defined (__HASTE__)
data Anim = Anim Int (Int, Int) (Int, Int)
data Game = Game (Maybe Anim) Board (Int, Int)

getColour n = rgb x x x where
  x | n == hole = 0
    | otherwise = 255 - (225 * (n - 1) `div` (side^2 - 1))

frameCount = 8
sz = 64

main = do
  canvas <- mustCanvas
  won <- newIORef undefined
  game <- newIORef undefined
    win = do
      writeIORef won True
      setInner "msg" "A WINNER IS YOU"
    draw b = forM_ (M.assocs b) $ \((r, c), n) -> fillrect canvas (c*sz) (r*sz) sz sz $ getColour n
    loop = do
      Game a b cur <- readIORef game
      case a of
        Nothing -> when (b == goal) win
        Just (Anim frame tgt@(r1,c1) src@(r0,c0)) -> do
          let sc b a = a*sz + (b - a)*sz*frame`div`frameCount
          writeIORef game $ Game
            (if frame == frameCount then Nothing else Just $ Anim (frame + 1) tgt src) b cur
          fillrect canvas (c0*sz) (r0*sz) sz sz $ getColour hole
          fillrect canvas (c1*sz) (r1*sz) sz sz $ getColour hole
          fillrect canvas (sc c0 c1) (sc r0 r1) sz sz $ getColour $ b!src
          delayCall 16 loop

    newGame = do
      b <- gen
      let Just cur = fst <$> find ((== hole) . snd) (M.assocs b)
      writeIORef game $ Game Nothing b cur
      writeIORef won False
      setInner "msg" ""
      draw b
    move tgt (Game anim b cur) = do
      writeIORef game $ Game
        (Just $ Anim 0 tgt cur)
        (M.insert tgt hole $ M.insert cur (b!tgt) b)
      case anim of
        Nothing -> loop
        Just _ -> draw b
    unlessWon f = readIORef won >>= flip unless f

  onMouseDown "reshuffle" $ \_ -> newGame

  onMouseDown "canvas" $ \e -> unlessWon $ do
    let tgt@(r, c) = (div (offsetY e) sz, div (offsetX e) sz)
    g@(Game _ b (r0, c0)) <- readIORef game
    when (M.member (r, c) b && (c - c0)^2 + (r - r0)^2 == 1) $ move tgt g

  onKeyDown $ \k -> unlessWon $ do
    g@(Game _ b (r, c)) <- readIORef game
      go tgt = when (M.member tgt b) $ do
#ifdef __HASTE__
        move tgt g
    case keyCode k of
      38  -> go (r + 1, c)
      40  -> go (r - 1, c)
      37  -> go (r, c + 1)
      39  -> go (r, c - 1)
      _ -> pure ()

In this page, we use the output of the Haste compiler, which is significantly smaller than the output of Asterius.

hastec --opt-all 15.lhs

162153 15.js

ahc-link --bundle --browser --ghc-option -O --input-hs 15.lhs

 96075 15.js
811685 15.wasm

Ben Lynn blynn@cs.stanford.edu 💡