Layout thought of as an attribute grammar, encoded in Haskell

FunPix.hs

--
-- Some experiments with a Picture type based on an attribute-grammar
-- model of Layout

module FunPic where

import Haven

-- A type for representing the dimensions of a rectangle, as (width,height)
type Dimension = (Double,Double)

type Bounds = Rectangle

-- A FunPic inherits a maximum Dimension and a RenderContext, 
-- and synthesizes a minimum Dimension and a picture.
--
type FunPic = RenderContext -> Dimension -> (Dimension,Picture)

-- An anchor point within a box:
data Anchor = N | S | W | E | NW | NE | SW | SE | C

text :: String -> FunPic
text s rc _ =
  let tp = textPic s
      bounds = picBounds tp rc
  in (rdim bounds,tp)

-- rdim: the Dimension of a Rectangle
rdim :: Rectangle -> Dimension
rdim r = (rectWidth r,rectHeight r)

-- tbox: just renders a bounding box around the bounds of its child
tbox :: FunPic -> FunPic
tbox child rc dim = 
  let (cmind,cpic) = child rc dim
      cbounds = picBounds cpic rc
      boxPic = withColor red (outlinePic cbounds)
  in (cmind,boxPic `overPic` cpic)

-- pcborder: surrounds it child by a border that is the given percentage
-- larger than the child
pcborder :: Double -> FunPic -> FunPic
pcborder pc child rc maxDim =
  let ((childMinW,childMinH),childPic) = child rc maxDim
      minWidth = childMinW * (1 + pc)
      minHeight = childMinH * (1 + pc)
      minDim = (minWidth,minHeight)
      -- now center child within the border:
      dim@(w,h) = dmax minDim maxDim
      -- now center the child within the boxPic:
      childBounds = picBounds childPic rc
      dx = (w - (rectWidth childBounds)) / 2
      dy = (h - (rectHeight childBounds)) / 2
      ctrChildPic = (translate (point dx dy)) %$ childPic
      boundsRect = rectangle origin w h
      boxedPic = clipPic boundsRect ctrChildPic
  in (minDim, boxedPic)

-- cbox places its argument picture in a box that is at least the given
-- percent larger than the bounding box of the child picture.
--
-- The cbox will try to expand up to max(minDim,maxDim)

cbox :: FunPic -> Double -> FunPic
cbox child pc rc maxDim =
  let ((childMinW,childMinH),childPic) = child rc maxDim
      minWidth = childMinW * (1 + pc)
      minHeight = childMinH * (1 + pc)
      minDim = (minWidth,minHeight)
      dim@(w,h) = dmax minDim maxDim
      boxPic = withColor red (outlinePic (drect dim))
      -- now center the child within the boxPic:
      childBounds = picBounds childPic rc
      dx = (w - (rectWidth childBounds)) / 2
      dy = (h - (rectHeight childBounds)) / 2
      ctrChildPic = (translate (point dx dy)) %$ childPic
  in (minDim, boxPic `overPic` ctrChildPic)

drect :: Dimension -> Rectangle
drect (w,h) = rectangle origin w h

dmax :: Dimension -> Dimension -> Dimension
dmax (w1,h1) (w2,h2) = (max w1 w2, max h1 h2)

-- rectangle whose width and height are the max. of each argument:
-- (smallest rectangle that encloses both)?
rmax :: Rectangle -> Rectangle -> Rectangle
rmax r1 r2 = 
  rectangle origin 
	    (max (rectWidth r1) (rectWidth r2)) 
	    (max (rectHeight r1) (rectHeight r2))

-- tcenter: Center a tightened picture in the given container

-- N.B.: by "tightening", we mean setting the child's max. bounds to
-- its min. bounds.
tcenter :: FunPic -> FunPic
tcenter child rc maxDim =
  let (childMinDim,childPic) = child rc childMinDim
      -- of course, our minDim is the same as our child's:
      minDim = childMinDim
      -- but our actual dimension is the space we are given:
      dim@(w,h) = maxDim
      childBounds = picBounds childPic rc
      dx = (w - (rectWidth childBounds)) / 2
      dy = (h - (rectHeight childBounds)) / 2
      ctrChildPic = (translate (point dx dy)) %$ childPic
  in (minDim, ctrChildPic)

-- place: place a picture at some absolute position:
place :: RenderContext -> Point -> Picture -> Picture
place rc pt pic =
  let bounds = picBounds pic rc
      ul = rectPtA bounds
      dx = pointX pt - pointX ul
      dy = pointY pt - pointY ul
  in translate (point dx dy) %$ pic


-- spread the given pictures vertically, and make them all the same size:
vspread :: FunPic -> FunPic -> FunPic
vspread topFP botFP rc maxDim@(w,h) =
  let (topMinDim, topPic) = topFP rc childMaxDim
      (botMinDim, botPic) = botFP rc childMaxDim
      childMaxDim@(cmw, cmh) = dmax topMinDim botMinDim
      -- now distribute the children evenly:
      topBounds = picBounds topPic rc
      botBounds = picBounds botPic rc
      vspace = h - ((rectHeight topBounds) + (rectHeight botBounds))
      dv = vspace / 3
      hspace = w - cmw
      topPic' = place rc (point (hspace / 2) dv) topPic
      botPic' = place rc (point (hspace / 2) (dv*2 + (rectHeight topBounds))) botPic
  in (childMaxDim,topPic' `overPic` botPic')

testFP :: FunPic -> IO ()
testFP fpic =
  let dim = (400,400)
      bpic = withColor blue (outlinePic (drect dim))
  in do w <- openWindow "Test 10" 200 200 500 500
        let (_,pic) = fpic (windowRenderContext w) dim
        setPicture w (bpic `overPic` pic)

-- anchor some point on this picture to some point in the immediate parent:
anchorToParent :: FunPic -> Anchor -> Anchor -> FunPic
anchorToParent child ca pa rc dim = undefined


fpic0 = text "hello, World!"

fpic1 = cbox fpic0 0.1

fpic2 = cbox (text "hi") 0.1

fpic3 = cbox (text "there sally horse!") 0.1

fpic4 = vspread fpic2 fpic3

fpic5 = tcenter $ tbox (pcborder 0.25 (text "hello"))

fpic6 = tcenter (text "hello")

fpic7 = tbox (text "hello")

fpic8 = tcenter (tbox (text "hello"))