{-# LANGUAGE FlexibleContexts, FlexibleInstances, BangPatterns,
TypeSynonymInstances, PatternGuards, MultiParamTypeClasses #-}
module Box(Box(..), BoxAlign(..), BoxPrim(..), BoxPlaced(..), BoxDim, BoxVec(..), BoxCo,
boxLayoutTop, boxVecScale, boxVecScales, boxVecSum, boxVecDiff) where
import Control.Monad
import Control.Monad.Writer
import Control.Monad.Identity
import Control.Monad.State
import Data.Traversable as Traversable
import Data.Foldable as Foldable
import Data.Functor as Fuctor
import Control.Applicative as Applicative
import Data.List (transpose)
import Prelude hiding (concat, foldr1, sum)
import Number
-- Boxes
-- A box is either a primitive box or a composite box which composes
-- (stacks) boxes along a particular axis.
data Box p = BoxMatrix [BoxAlign] [BoxAlign] [[Box p]]
| BoxLayers [Box p]
| BoxPrim p
deriving Show
-- Rev is negative side of axis while Fwd is positive.
-- Left = Rev, X
-- Right = Fwd, X
-- Up = Fwd, Y
-- Down = Rev, Y -> Text flows downward == decreasing coord.
data BoxAlign = BoxAlignInherit
| BoxAlignFrac Number
{- | BoxAlignRev | BoxAlignCenter | BoxAlignFwd -}
deriving Show
-- BoxCo vectors and operations
data BoxVec = BoxVec {
boxVec :: [Number]
} deriving (Show, Eq) -- Ordinary n-dim vector
type BoxCo = BoxVec -- A coordinate is a vector relative to screen origin
type BoxDim = BoxVec -- A box dimension is a vector relative to it's lower left corner.
type BoxAxis = Int -- Index into BoxVec's list
boxVecSum (BoxVec as) (BoxVec bs) = BoxVec $ zipWith (+) as bs
boxVecDiff (BoxVec as) (BoxVec bs) = BoxVec $ zipWith (-) as bs
boxVecScale s (BoxVec as) = BoxVec $ map (* s) as
boxVecScales ss (BoxVec as) = BoxVec $ zipWith (*) as ss
-- Layout algo requires a box primitive to have dimensions.
class BoxPrim p where
boxDim :: p -> BoxDim
dimBox :: BoxDim -> p -- for debugging
-- Instance used for testing layout algo: a box with nothing but a size.
instance BoxPrim BoxDim where
boxDim x = x
dimBox x = x
-- The layout algorithm goes something like this:
-- stacker: box1, how big are you
-- box1: I'm .... (possibly recursively determined)
-- stacker: box2, how big are you
-- ...
-- stacker: parent, I'm this big
-- parent: ok, go here, and shrink/grow
-- stacker: box1, go here and s/g...
-- box1: here's my list of allocated children
-- stacker: box2, go here and s/g ...
-- box2: here's my list of allocated children
-- stacker: parent, here's my list of allocated children
-- ...
-- This is essentially a 2-pass algorithm with a bottom-up and a
-- top-down information flow. The second pass is represented by a
-- closure/continuation.
-- First pass (non-primitive case) takes a collection of boxes, and
-- returns the bounding box and the 2nd pass continuation/closure.
boxLayout :: BoxPrim p => Box p -> (BoxDim, BoxPlace p)
-- The second pass takes a place and (possibly larger) bounding box
-- from parent and returns a list of all recursively placed primitive
-- children.
type BoxPlace p = BoxCo -> BoxDim -> [BoxPlaced p]
-- FIXME: add wrapper for clarity
data BoxPlaced p = BoxPlaced {
boxPlacedCo :: BoxCo,
boxPlacedDim :: BoxDim,
boxPlacedPrim :: p
}
debug :: a -> [a] -> [a]
-- debug x l = x:l
debug x l = l
boxLayout (BoxPrim p) = (boxDim p, cont) where
cont coord dim = debug (BoxPlaced coord dim $ dimBox dim) [BoxPlaced coord dim p]
boxLayout (BoxLayers bxs) = (bbox, cont) where
(bboxs, conts) = unzip $ map boxLayout (reverse bxs)
bbox = boundingBox bboxs where
boundingBox bboxs = BoxVec $ foldr1 (zipWith max) (map boxVec bboxs)
cont coord dim = concat $ map (\cont -> cont coord dim) conts
boxLayout (BoxMatrix alignWidth alignHeight bxs) = (bbox, cont) where
dims_conts = mapm boxLayout bxs
dims = mapm fst dims_conts
(widths : heights : _) = cellBounds (mapm boxDim dims)
bbox = BoxVec $ map sum [widths, heights]
cont coord fillBox@(BoxVec [bh',bw']) = placed where
-- Distrubute the (larger) boundingbox over subboxes.
widths' = applyInherit bh' alignWidth widths
heights' = applyInherit bw' alignHeight heights
-- bbox' = BoxVec $ map sum [widths', heights']
-- Flatten results. Make sure that the order of boxes is the same
-- as in Traversable instance, since this reflects the text flow.
placed = d $ c $ c $ reverse $ subs -- flatten results
c = concat
d = debug (BoxPlaced coord fillBox $ dimBox fillBox)
grid = cross (,)
(zip alignWidth (psum widths'))
(zip alignHeight (psum heights'))
subs = zipm2 subbox dims_conts grid
-- Perform subbox placement given original dimensions, cell size
-- and cell coordinates
subbox (origBox, cont) ((aw, (w,x)), (ah, (h,y))) = sub where
(offset, fillBox') = alignOffset [aw,ah] origBox (BoxVec [w,h])
coord' = boxVecSum coord $ boxVecSum offset $ BoxVec [x,y]
sub = cont coord' fillBox'
-- Cells that have inherit will all take a piece of the cake.
applyInherit b as bs = bs' where
bs' = dist $ sum $ map wants as
wants BoxAlignInherit = 1
wants _ = 1 -- 0: FIXME: always inherit, it looks better.. maybe move to badness approach anyway.
dist 0 = bs
dist n = zipWith addSome as bs where
extra = (b - sum bs) / fromInteger n
addSome a b = b + (wants a) * extra
-- Compute child box location and size from alignment spec.
-- BoxAlignInherit: 0 = left, 1/2 = center, 1 = right.
alignOffset align (BoxVec box) (BoxVec cell) = (BoxVec os, BoxVec bs) where
(os, bs) = unzip $ zipWith3 f align box cell where
f BoxAlignInherit b c = (0, c) -- Pass cell dim to child
f (BoxAlignFrac a) b c = (a * (c - b), b) -- Align + pass real dim
boxLayoutTop loc bbox b = locs where
(_, cont) = boxLayout b
locs = cont loc bbox
-- The general rule for Traverse is:
-- like fmap, but with .. <$> .. <*> .. <*> .. on the right
-- http://www.soi.city.ac.uk/~ross/papers/Applicative.pdf
-- In the case below it's really just <$> since we can use the
-- Traverse instance of lists.
traverseBox :: Applicative f
=> (p -> f q)
-> Box p
-> f (Box q)
traverseBox f = trav where
trav (BoxPrim p) = fmap BoxPrim $ f p
trav (BoxLayers bs) = BoxLayers <$> traverse trav bs
-- Reverse y coord for traversal for proper text direction.
trav bm@(BoxMatrix ax ay bss) = fb where
fb = (BoxMatrix ax ay) . reverse <$> fbs
fbs = traverse (traverse trav) (reverse bss)
{- TEST
c1 = BoxPrim ()
m1 = BoxMatrix [] []
[[c1,c1],
[c1,c1]]
runState (Traversable.forM m1 (\_ -> do modify (+1); return 123)) 0
-}
instance Traversable Box where traverse = traverseBox
-- Is there a simpler way to do thise two instances automatically?
-- Also, not defining instance of foldr or foldMap causes an infinite
-- loop because they are defined in terms of each other.
instance Functor Box where
fmap f b = runIdentity $ traverse (\x -> return $ f x) b
instance Foldable Box where
-- Also work with RState, but can't find a library function. This
-- is dual to foldl: instead of keeping track and updating a value,
-- a hole is updated instead.
foldr f s b = k' s where
(_, k') = runState (traverse f' b) (\s -> s)
f' b = modify (\k -> (\s -> k $ f b s))
{-
foldr f s b = s' where
(_, s') = runRState (traverse f' b) s
f' b = modify (f b)
-}
-- Mainly for contrast with foldr.
foldl f s b = s' where
(_, s') = runState (traverse f' b) s
f' b = modify (flip f b)
-- map function over matrix
mapm f = map (map f)
-- analogous for zip
zipm2 f = zipWith (zipWith f)
zipm3 f = zipWith3 (zipWith3 f)
-- vector cross prod
cross f xs ys = map (\y -> map (\x -> f x y) xs) ys
psum l = l' where -- annotate number list with partial sum
(_, l') = mapAccumL f 0 l
f s e = (s + e, (e, s))
-- Compute matrix cell bounding boxes. Limited to 2D because I don't
-- know how to express transposes in a generic way.
-- Convert matrix of bounding boxes to matrix of full cell dimensions.
cellBounds bbs = [pws, phs] where
-- Plumbing tools
maxi = map $ foldr1 max -- fold matrix rows with max
-- Matrix of widths and heights
ws = mapm (\(BoxVec (w:h:_)) -> w) bbs
hs = mapm (\(BoxVec (w:h:_)) -> h) bbs
-- Fold both to projected cell bounding box dimensions
pws = maxi $ transpose ws
phs = maxi $ hs
matrixBoxes [pws, phs] = (bb', bbs') where
-- Restore bounding boxes from projections
bbs' = cross (\x y -> BoxVec [x,y]) pws phs
bb' = BoxVec [sum pws, sum phs]
boundMatrix = matrixBoxes . cellBounds
{- TEST
t1 = boxLayoutTop (BoxVec [-20,-10]) (BoxVec [40,20]) b where
a = BoxAlignFrac 0.5
b = BoxMatrix [a,a] [a,a] m
m = [[c',c],[c,c]]
c = BoxPrim $ BoxVec [1,1]
c' = BoxPrim $ BoxVec [2,2]
-}