module Matrix(aaMatrix, uaMatrix, auMatrix, uuMatrix, xxMatrix, xxArrowMatrix) where
import List(transpose)

import SlideWare

-- All cells of the same size
aaMatrix :: Number -> Number -> Bool -> [[Pict]] -> Pict
aaMatrix = xxMatrix True True

-- All cells of the same height
uaMatrix :: Number -> Number -> Bool -> [[Pict]] -> Pict
uaMatrix = xxMatrix False True

-- All cells of the same width
auMatrix :: Number -> Number -> Bool -> [[Pict]] -> Pict
auMatrix = xxMatrix True False

-- Adaptive size
uuMatrix :: Number -> Number -> Bool -> [[Pict]] -> Pict
uuMatrix = xxMatrix False False

xxMatrix :: Bool -> Bool -> Number -> Number -> Bool -> [[Pict]] -> Pict
xxMatrix eqw eqh dx dy frm [] = empty
xxMatrix eqw eqh dx dy frm pss =
    let pss' = padMatrix empty pss
	sz = ghost $ ccSuperimpose $ concat pss'
	hs =
	    if eqh then
		repeat $ height sz
	    else
		map (height . ccSuperimpose) pss'
	ws = 
	    if eqw then
		repeat $ width sz
	    else
		map (width . ccSuperimpose) $ transpose pss'

	sup h = zipWith (\ w p -> frmIt $ outSet dx dy $ ccSuperimpose [p, h, w]) ws
	frmIt = if frm then frame else id
    in  vcAppend $ zipWith (\ h ps -> hcAppend $ sup h ps) hs pss'

outSet dx dy p =
	vcAppend [blank 0 (dy/2),
		  hcAppend [blank (dx/2) 0, p, blank (dx/2) 0],
		  blank 0 (dy/2)]
empty = blank 0 0

padMatrix :: a -> [[a]] -> [[a]]
padMatrix x xss =
    let l = maximum (map length xss)
	pad xs = xs ++ replicate (l - length xs) x
    in  map pad xss

-- Return a 0 width pict of the same height as the argument
height :: Pict -> Pict
height p =
    let p' = label "a" p
	lt = findLT "a" p'
	lb = findLB "a" p'
    in  ghost $ lineWidth 0 $ arrow (lt, lb)

-- Return a 0 height pict of the same width as the argument
width :: Pict -> Pict
width p =
    let p' = label "a" p
	lt = findLT "a" p'
	rt = findRT "a" p'
    in  ghost $ lineWidth 0 $ arrow (lt, rt)

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

type Dest = (Int, Int)
type PictDests = (Pict, [Dest])

xxArrowMatrix :: Bool -> Bool -> Number -> Number -> [[PictDests]] -> Pict
xxArrowMatrix eqw eqh dx dy pdss =
    let pss = zipWith (\ y pds -> zipWith ( \ x (p, _) -> label (show(x,y)) p) [1..] pds) [1..] pdss

	mp = xxMatrix eqw eqh dx dy False pss
	asss = zipWith (\ y pds -> zipWith ( \ x (_, ds) -> map (arr x y) ds) [1..] pds) [1..] pdss
	arr x y (ox, oy) =
	    let (fs, fd) = findSD ox oy
		ps = fs (show (x,y)) mp
		pd = fd (show (x+ox, y+oy)) mp
	    in  arrow (ps, pd)
	ap = ltSuperimpose $ concat (map concat asss)
    in  ltSuperimpose [ap, mp]

findSD ox oy =
    case (signum ox, signum oy) of
    ( 1, 1) -> (findRB, findLT)
    ( 1, 0) -> (findRC, findLC)
    ( 1,-1) -> (findRT, findLB)
    ( 0, 1) -> (findCB, findCT)
    ( 0, 0) -> error "xxArrowMatrix"
    ( 0,-1) -> (findCT, findCB)
    (-1, 1) -> (findLB, findRT)
    (-1, 0) -> (findLC, findRC)
    (-1,-1) -> (findLT, findRB)