--------------------------------------------------
-- Copyright 1994 by Peter Thiemann
-- $Log: EbnfLayout.hs,v $
-- Revision 1.1  2004/08/05 11:11:57  malcolm
-- Add a regression testsuite for the nhc98 compiler.  It isn't very good,
-- but it is better than nothing.  I've been using it for about four years
-- on nightly builds, so it's about time it entered the repository!  It
-- includes a slightly altered version of the nofib suite.
-- Instructions are in the README.
--
-- Revision 1.2  1996/07/26 21:21:58  partain
-- Final changes for 2.01
--
-- Revision 1.1  1996/01/08 20:02:34  partain
-- Initial revision
--
-- Revision 1.4  1994/03/15  15:34:53  thiemann
-- added full color support, XColorDB based
--
-- Revision 1.3  1994/02/18  11:59:29  thiemann
-- save state before adding "withTentacle"
--
--Revision 1.2  1993/08/31  12:31:32  thiemann
--reflect changes in type FONT
--
--Revision 1.1  1993/08/17  12:34:29  thiemann
--Initial revision
--
-- $Locker:  $
--------------------------------------------------
module EbnfLayout where

import AbstractSyntax
import Color
import Fonts (FONT, stringWidth, stringHeight, fontDescender)
import Info
import List--1.3

-- all arithmetic is done in 1/100 pt

-- tFont, ntFont :: Font
-- arrowSize, lineWidth, fatLineWidth, borderDistY, borderDistX :: Int

-- borderDistX = 500
-- borderDistY = 500
-- lineWidth   = 20
-- fatLineWidth = 200
-- arrowSize   = 300
-- ntFont	    = ("Times-Roman", 10)
-- tFont       = ("Times-Roman", 10)

makePictureLayout :: INFO -> Production -> Container
makePictureLayout
    (borderDistX, borderDistY, lineWidth, fatLineWidth, arrowSize, ntFont, tFont,
	(ntColor, tColor, lineColor, fatLineColor))
    prod
    = makePicture 0 0 1 prod
	where

  mkNonTerminal :: String -> Int -> Int -> Container
  mkNonTerminal str rx ry = (rx, ry, width, height, 0, AString ntColor ntFont str)
	where 
	      width  = stringWidth  ntFont str
	      height = stringHeight ntFont str

  mkTerminal :: String -> Int -> Int -> Container
  mkTerminal str rx ry = (rx, ry, width, height, 0, AString tColor tFont str)
	where 
	      width  = stringWidth  tFont str
	      height = stringHeight tFont str

  mkBox :: Int -> Int -> Int -> Int -> Int -> Container -> Container
  mkBox rx ry width height inOutY content
    = (rx, ry, width, height, inOutY, ABox fatLineColor False content)

  mkRoundBox :: Int -> Int -> Int -> Int -> Int -> Container -> Container
  mkRoundBox rx ry width height inOutY content
    = (rx, ry, width, height, inOutY, ABox fatLineColor True content)

  mkLine ::  Int -> Int -> Int -> Int -> Container
  mkLine rx ry w h = (rx, ry, w, h, 0, Aline lineColor)

  mkArrow :: Int -> Int -> Int -> Container
  mkArrow rx ry dir = (rx, ry, 0, 0, 0, Arrow lineColor (dir*arrowSize))

  mkTurn :: Int -> Int -> Int -> Int -> TDirection -> Container
  mkTurn rx ry w h t = (rx, ry, w, h, 0, ATurn lineColor t)

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

  withTentacle :: Int -> Int -> Int -> Production -> Container
  withTentacle rx ry direction prod = 
	(rx, ry, width, height, inOutY, AComposite [contents, theLine, theArrow])
	where (_, _, width1, height, inOutY, _) = contents
	      contents = makePicture rx1 0 direction prod
	      width = width1 + borderDistX
	      rx1      | direction > 0 = 0
                       | otherwise     = borderDistX
	      theLine  | direction > 0 = mkLine  width1 inOutY borderDistX 0
	               | otherwise     = mkLine  0      inOutY borderDistX 0
	      theArrow | direction > 0 = mkArrow width  inOutY direction
                       | otherwise     = mkArrow 0      inOutY direction

  makePicture :: Int -> Int -> Int -> Production -> Container

  makePicture rx ry direction (ProdProduction ntName ntAliases prod) =
	(rx, ry, width, height, 0, AComposite ([content1, content2]++glue))
	where (_, _, width1, height1, inOutY1, _) = content1
	      content1 = withTentacle rx1 ry1 direction prod
	      content2@(_,_, width2, height2,_,_) = mkNonTerminal str rx2 ry2
	      rx1 = 2*borderDistX
	      ry1 = fatLineWidth `div` 2
	      rx2 = 0
	      ry2 = ry1 + height1 + distance - fontDescender ntFont
	      distance = 2*borderDistY
	      width = 2*borderDistX + max width1 width2
	      height = height1 +fatLineWidth + height2 + distance
	      glue = [
		mkLine 0 (ry1 + inOutY1) (2*borderDistX) 0,
		mkArrow rx1 (ry1 + inOutY1) direction]
	      str = case ntAliases of
			[] -> ntName
			newName:_ -> newName

  makePicture rx ry direction (ProdTerm [prod]) =
	makePicture rx ry direction prod
  makePicture rx ry direction (ProdTerm prods) =
	(rx, ry, width, height, inOutY, AComposite (newcontents ++ glue))
	where newcontents = zip6 rxs rys widths heights inOutYs gobjs
	      (_, _, widths, heights, inOutYs, gobjs) = unzip6 contents
	      ncontents = length prods
	      -- sadly enough it's not possible to take rxs and rys in place of the fakes!
	      fakes = take ncontents (repeat 0)
	      contents = zipWith4 makePicture fakes fakes directions prods
	      height = sum heights + (ncontents-1) * borderDistY
	      maxwidth = maximum widths
	      width = maxwidth + 4 * borderDistX
	      rxs | direction > 0 = take ncontents (repeat (2 * borderDistX))
		  | otherwise     = map ((+ 2*borderDistX) . (maxwidth -)) widths
	      rys = tail (scanr f 0 heights) where f h q = h + q + borderDistY
              directions = take ncontents (repeat direction)
	      entries = zipWith (+) rys inOutYs		    -- frame relative Y positions of entries
	      firstEntry = entries!!0
	      lastEntry = entries!!(ncontents-1)
	      middleEntries = init (tail entries)
	      inOutY = (firstEntry + lastEntry) `div` 2
	      inOutDiff = firstEntry - lastEntry - 2*borderDistY
	      glue = fixedglue ++ variableglue
	      fixedglue = [
		mkLine 0 inOutY borderDistX 0,
		mkLine (width-borderDistX) inOutY borderDistX 0,
		mkTurn borderDistX (firstEntry - borderDistY) borderDistX borderDistY SE,
		mkTurn borderDistX lastEntry   borderDistX borderDistY NE,
		mkLine borderDistX (lastEntry + borderDistY) 0 inOutDiff,
		mkTurn (width-2*borderDistX) (firstEntry - borderDistY) borderDistX borderDistY SW,
		mkTurn (width-2*borderDistX) lastEntry borderDistX borderDistY WN,
		mkLine (width-borderDistX) (lastEntry + borderDistY) 0 inOutDiff] ++
		map f middleEntries ++
		map g middleEntries
			where f y = mkLine borderDistX           y borderDistX 0
			      g y = mkLine (width-2*borderDistX) y borderDistX 0
	      variableglue | direction > 0 = zipWith g widths entries
			   | otherwise     = zipWith h widths entries
			where g w y = mkLine (2*borderDistX + w) y (maxwidth - w) 0
			      h w y = mkLine (2*borderDistX)     y (maxwidth - w) 0
	      obsoleteglue =
			map (f (2*borderDistX)) entries
			where f x y = mkArrow x y direction

{- the following works for two terms, both directions
  makePicture rx ry direction (ProdTerm [prod1, prod2])
    | direction > 0 =
	let   (_, _, width1, height1, inOutY1, _) = content1
	      content1 = makePicture rx1 ry1 direction prod1
	      (_, _, width2, height2, inOutY2, _) = content2
	      content2 = makePicture rx2 ry2 direction prod2
	      rx1 = 2*borderDistX
	      rx2 = 2*borderDistX
	      ry2 = 0
	      ry1 = height2 + borderDistY
	      maxwidth = max width1 width2
	      width = 4*borderDistX + maxwidth
	      height = height2 + borderDistY + height1
	      inOutY = (inOutY2 + ry1 + inOutY1) `div` 2
	      inOutDiff = ry1 + inOutY1 - inOutY2 - 2*borderDistY
	      glue = [
		mkLine 0 inOutY borderDistX 0,
		mkLine (width - borderDistX) inOutY borderDistX 0,
		mkLine borderDistX (ry2 + inOutY2 + borderDistY) 0 inOutDiff,
		mkLine (width - borderDistX) (ry2 + inOutY2 + borderDistY) 0 inOutDiff,
		mkTurn borderDistX (ry1 + inOutY1 - borderDistX) borderDistX borderDistY SE,
		mkTurn borderDistX inOutY2 borderDistX borderDistY NE,
		mkTurn (width - 2*borderDistX) (ry1 + inOutY1 - borderDistX) borderDistX borderDistY SW,
		mkTurn (width - 2*borderDistX) inOutY2 borderDistX borderDistY WN,
		mkLine (rx1 + width1) (ry1 + inOutY1) (maxwidth - width1) 0,
		mkLine (rx2 + width2) (ry2 + inOutY2) (maxwidth - width2) 0]
	in      (rx, ry, width, height, inOutY, AComposite ([content1,content2]++glue))
    | otherwise =
	let   (_, _, width1, height1, inOutY1, _) = content1
	      content1 = makePicture rx1 ry1 direction prod1
	      (_, _, width2, height2, inOutY2, _) = content2
	      content2 = makePicture rx2 ry2 direction prod2
	      maxwidth = max width1 width2
	      width = 4*borderDistX + maxwidth
	      height = height2 + borderDistY + height1
	      inOutY = (inOutY2 + ry1 + inOutY1) `div` 2
	      inOutDiff = ry1 + inOutY1 - inOutY2 - 2*borderDistY
	      rx1 = 2*borderDistX + (maxwidth - width1)
	      rx2 = 2*borderDistX + (maxwidth - width2)
	      ry2 = 0
	      ry1 = height2 + borderDistY
	      glue = [
		mkLine 0 inOutY borderDistX 0,
		mkLine (width - borderDistX) inOutY borderDistX 0,
		mkLine borderDistX (ry2 + inOutY2 + borderDistY) 0 inOutDiff,
		mkLine (width - borderDistX) (ry2 + inOutY2 + borderDistY) 0 inOutDiff,
		mkTurn borderDistX (ry1 + inOutY1 - borderDistX) borderDistX borderDistY SE,
		mkTurn borderDistX inOutY2 borderDistX borderDistY NE,
		mkTurn (width - 2*borderDistX) (ry1 + inOutY1 - borderDistX) borderDistX borderDistY SW,
		mkTurn (width - 2*borderDistX) inOutY2 borderDistX borderDistY WN,
		mkLine (2*borderDistX) (ry1 + inOutY1) (maxwidth - width1) 0,
		mkLine (2*borderDistX) (ry2 + inOutY2) (maxwidth - width2) 0]
	in      (rx, ry, width, height, inOutY, AComposite ([content1,content2]++glue))
-}

  makePicture rx ry direction (ProdFactor [prod]) =
	makePicture rx ry direction prod
{-
  makePicture rx ry direction (ProdFactor prods) =
	(rx, ry, width, height, inOutY, AComposite (glue++contents))
	where (_, _, widths, heights, inOutYs, gobjs) = unzip6 contents
	      contents = zipWith4 makePicture rxs rys directions prods
	      ncontents = length prods
	      aboves = zipWith (-) heights inOutYs
	      maxIO = maximum inOutYs
	      height = maxIO + maximum aboves
	      width = sum widths + (ncontents-1)*borderDistX
	      inOutY = maxIO
	      rxs
		  -- = take ncontents [0, 20*borderDistX .. ]
		  | direction > 0 = init (scanl f 0 widths)
	          | otherwise     = tail (scanr f 0 widths)
		       where f q w = q + w + borderDistX

	      rys =
			take ncontents (repeat 0)
	      		-- map (inOutY -) inOutYs
	      directions = take ncontents (repeat direction)
	      glue | direction > 0 = map f (tail rxs)
		   | otherwise     = map f (init rxs)
			where  f x = mkLine (x-borderDistX) inOutY borderDistX 0
-}

  makePicture rx ry direction (ProdFactor [prod1,prod2]) 
    | direction > 0 =
	let   (_, _, width1, height1, inOutY1, _) = content1
	      content1 = withTentacle rx1 ry1 direction prod1
	      (_, _, width2, height2, inOutY2, _) = content2
	      content2 = makePicture rx2 ry2 direction prod2
	      rx1 = 0
	      rx2 = width1
	      width = width1 + width2
	      inOutY = max inOutY1 inOutY2
	      ry1 = inOutY - inOutY1
	      ry2 = inOutY - inOutY2
	      height = inOutY + max (height1 - inOutY1) (height2 - inOutY2)
	in    (rx, ry, width, height, inOutY, AComposite ([content1,content2]))
    | otherwise =
	let   (_, _, width1, height1, inOutY1, _) = content1
	      content1 = withTentacle rx1 ry1 direction prod1
	      (_, _, width2, height2, inOutY2, _) = content2
	      content2 = makePicture rx2 ry2 direction prod2
	      rx2 = 0
	      rx1 = width2
	      width = width1 + width2
	      inOutY = max inOutY1 inOutY2
	      ry1 = inOutY - inOutY1
	      ry2 = inOutY - inOutY2
	      height = inOutY + max (height1 - inOutY1) (height2 - inOutY2)
	in    (rx, ry, width, height, inOutY, AComposite ([content1,content2]))

  makePicture rx ry direction (ProdFactor (prod:prods)) =
	makePicture rx ry direction (ProdFactor [prod, ProdFactor prods])
-- this is a ghastly hack!

  makePicture rx ry direction (ProdNonterminal str) =
	mkBox rx ry width height inOutY content
	where content@(_,_,width', height',_,_) = mkNonTerminal str rx' ry'
	      width   = width' + 2*borderDistX + 2*fatLineWidth
	      height  = height' + borderDistY + 2*fatLineWidth
	      rx'     = fatLineWidth + borderDistX
	      ry'     = fatLineWidth + borderDistY `div` 2 - fontDescender ntFont
	      inOutY  = height `div` 2

  makePicture rx ry direction (ProdTerminal str) =
	mkRoundBox rx ry width height inOutY content
	where content@(_,_,width', height',_,_) = mkTerminal str rx' ry'
	      width   = width' + 2*borderDistX + 2*fatLineWidth
	      height  = height' + borderDistY + 2*fatLineWidth
	      rx'     = fatLineWidth + borderDistX
	      ry'     = fatLineWidth + borderDistY `div` 2 - fontDescender tFont
	      inOutY  = height `div` 2

  makePicture rx ry direction (ProdOption prod) =
	(rx, ry, width, height, inOutY, AComposite (content:glue))
	where (_, _, width', height', inOutY', gobj) = content
	      content = makePicture rx' ry' direction prod
	      width = width' + 6*borderDistX
	      height = height' + borderDistY
	      rx' = 3*borderDistX
	      ry' = borderDistY
	      inOutY = 0
	      glue = variableglue ++ fixedglue
	      fixedglue = [
		mkLine 0 0 width 0,
	        mkTurn 0 0 borderDistX bby WN,
	        mkTurn borderDistX (inOutY'+borderDistY-bby) borderDistX bby SE,
		mkLine (2*borderDistX) (ry'+inOutY') borderDistX 0,
	        mkTurn (width-borderDistX) 0 borderDistX bby NE,
	        mkTurn (width-2*borderDistX) (inOutY'+borderDistY-bby) borderDistX bby SW,
		mkLine (width-3*borderDistX) (ry'+inOutY') borderDistX 0,
	        mkLine borderDistX         bby 0 (inOutY'+borderDistY-2*bby),
	        mkLine (width-borderDistX) bby 0 (inOutY'+borderDistY-2*bby)]
		where bby = min borderDistY ((inOutY'+borderDistY) `div` 2)
	      variableglue
		| direction > 0 = [mkArrow (3*borderDistX) (ry'+inOutY') direction]
		| otherwise     = [mkArrow (width-3*borderDistX) (ry'+inOutY'+borderDistY) direction]

  makePicture rx ry direction (ProdRepeat prod) =
	(rx, ry, width, height, inOutY, AComposite (content:glue))
	where (_, _, width', height', inOutY', gobj) = content
	      content = makePicture rx' ry' (-direction) prod
	      width = width' + 4*borderDistX
	      height = height' + borderDistY
	      rx' = 2*borderDistX
	      ry' = borderDistY
	      inOutY = 0
	      glue = variableglue ++ fixedglue
	      fixedglue = [
		mkLine 0 0 width 0,
	        mkTurn borderDistX 0 borderDistX bby NE,
	        mkTurn borderDistX (inOutY'+borderDistY-bby) borderDistX bby SE,
	        mkTurn (width-2*borderDistX) 0 borderDistX bby WN,
	        mkTurn (width-2*borderDistX) (inOutY'+borderDistY-bby) borderDistX bby SW,
	        mkLine borderDistX     bby 0 (inOutY'+borderDistY-2*bby),
	        mkLine (width-borderDistX) bby 0 (inOutY'+borderDistY-2*bby)]
		where bby = min borderDistY ((inOutY'+borderDistY) `div` 2)
	      variableglue
		| direction < 0 = [mkArrow (2*borderDistX) (inOutY'+borderDistY) (-direction)]
		| otherwise     = [mkArrow (width-2*borderDistX) (inOutY'+borderDistY) (-direction)]
	      
  makePicture rx ry direction (ProdRepeat1 prod) =
	(rx, ry, width, height, inOutY, AComposite (content:glue))
	where (_, _, width', height', inOutY', gobj) = content
	      content = makePicture rx' ry' (direction) prod
	      width = width' + 4*borderDistX
	      height = height' + borderDistY
	      rx' = 2*borderDistX
	      ry' = 0
	      inOutY = inOutY'
	      glue = [
		mkLine 0 inOutY rx' 0,
		mkLine (rx'+width') inOutY rx' 0,
		mkTurn borderDistX inOutY borderDistX borderDistY NE,
		mkTurn borderDistX (height-borderDistY) borderDistX borderDistY SE,
		mkTurn (width-rx') inOutY borderDistX borderDistY WN,
		mkTurn (width-rx') (height-borderDistY) borderDistX borderDistY SW,
		mkLine borderDistX (inOutY+borderDistY) 0 (height'-inOutY'-borderDistY),
		mkLine (width-borderDistX) (inOutY+borderDistY) 0 (height'-inOutY'-borderDistY),
		mkLine rx' height width' 0,
		mkArrow (rx'+width' `div` 2) height (-direction)]
	      
  makePicture rx ry direction (ProdRepeatWithAtom prod1 prod2) =
	(rx, ry, width, height, inOutY, AComposite (content1:content2:glue))
	where (_, _, width1, height1, inOutY1, _) = content1
	      (_, _, width2, height2, inOutY2, _) = content2
	      content1 = makePicture rx1 ry1 direction prod1
	      content2 = makePicture rx2 ry2 (-direction) prod2
	      maxwidth = max width1 width2
	      width = maxwidth + 4*borderDistX
	      height = height1 + height2 + borderDistY
	      adjx1 = (maxwidth - width1) `div` 2
	      rx1 = 2*borderDistX + adjx1
	      ry1 = 0
	      adjx2 = (maxwidth - width2) `div` 2
	      rx2 = 2*borderDistX + adjx2
	      ry2 = height1 + borderDistY
	      inOutY = inOutY1
	      glue = variableglue ++ fixedglue
	      fixedglue = [
		mkLine 0 inOutY rx1 0,
	        mkLine (rx1 + width1) inOutY rx1 0,
	        mkLine (2*borderDistX) (ry2+inOutY2) adjx2 0,
	        mkLine (2*borderDistX + adjx2 + width2) (ry2+inOutY2) adjx2 0,
	        mkTurn borderDistX inOutY borderDistX borderDistY NE,
	        mkTurn borderDistX (ry2+inOutY2-borderDistY) borderDistX borderDistY SE,
	        mkTurn (rx1+width1+adjx1) inOutY borderDistX borderDistY WN,
	        mkTurn (rx1+width1+adjx1) (ry2+inOutY2-borderDistY) borderDistX borderDistY SW,
	        mkLine borderDistX (inOutY+borderDistY) 0 (height1-inOutY1 + inOutY2 - borderDistY),
	        mkLine (rx1+width1+adjx1+borderDistX) (inOutY+borderDistY) 0 (height1-inOutY1 + inOutY2 - borderDistY)]
	      variableglue
		| direction > 0 = [mkArrow (2*borderDistX + adjx2 + width2) (ry2+inOutY2) (-direction)]
		| otherwise     = [mkArrow (2*borderDistX + adjx2) (ry2+inOutY2) (-direction)]