1 -------------------------------------------------- 2 -- Copyright 1994 by Peter Thiemann 3 -- $Log: EbnfLayout.hs,v $ 4 -- Revision 1.2 1996/07/26 21:21:58 partain 5 -- Final changes for 2.01 6 -- 7 -- Revision 1.1 1996/01/08 20:02:34 partain 8 -- Initial revision 9 -- 10 -- Revision 1.4 1994/03/15 15:34:53 thiemann 11 -- added full color support, XColorDB based 12 -- 13 -- Revision 1.3 1994/02/18 11:59:29 thiemann 14 -- save state before adding "withTentacle" 15 -- 16 --Revision 1.2 1993/08/31 12:31:32 thiemann 17 --reflect changes in type FONT 18 -- 19 --Revision 1.1 1993/08/17 12:34:29 thiemann 20 --Initial revision 21 -- 22 -- $Locker: $ 23 -------------------------------------------------- 24 module EbnfLayout where 25 26 import AbstractSyntax 27 import Color 28 import Fonts (FONT, stringWidth, stringHeight, fontDescender) 29 import Info 30 import List--1.3 31 32 -- all arithmetic is done in 1/100 pt 33 34 -- tFont, ntFont :: Font 35 -- arrowSize, lineWidth, fatLineWidth, borderDistY, borderDistX :: Int 36 37 -- borderDistX = 500 38 -- borderDistY = 500 39 -- lineWidth = 20 40 -- fatLineWidth = 200 41 -- arrowSize = 300 42 -- ntFont = ("Times-Roman", 10) 43 -- tFont = ("Times-Roman", 10) 44 45 makePictureLayout :: INFO -> Production -> Container 46 makePictureLayout 47 (borderDistX, borderDistY, lineWidth, fatLineWidth, arrowSize, ntFont, tFont, 48 (ntColor, tColor, lineColor, fatLineColor)) 49 prod 50 = makePicture 0 0 1 prod 51 where 52 53 mkNonTerminal :: String -> Int -> Int -> Container 54 mkNonTerminal str rx ry = (rx, ry, width, height, 0, AString ntColor ntFont str) 55 where 56 width = stringWidth ntFont str 57 height = stringHeight ntFont str 58 59 mkTerminal :: String -> Int -> Int -> Container 60 mkTerminal str rx ry = (rx, ry, width, height, 0, AString tColor tFont str) 61 where 62 width = stringWidth tFont str 63 height = stringHeight tFont str 64 65 mkBox :: Int -> Int -> Int -> Int -> Int -> Container -> Container 66 mkBox rx ry width height inOutY content 67 = (rx, ry, width, height, inOutY, ABox fatLineColor False content) 68 69 mkRoundBox :: Int -> Int -> Int -> Int -> Int -> Container -> Container 70 mkRoundBox rx ry width height inOutY content 71 = (rx, ry, width, height, inOutY, ABox fatLineColor True content) 72 73 mkLine :: Int -> Int -> Int -> Int -> Container 74 mkLine rx ry w h = (rx, ry, w, h, 0, Aline lineColor) 75 76 mkArrow :: Int -> Int -> Int -> Container 77 mkArrow rx ry dir = (rx, ry, 0, 0, 0, Arrow lineColor (dir*arrowSize)) 78 79 mkTurn :: Int -> Int -> Int -> Int -> TDirection -> Container 80 mkTurn rx ry w h t = (rx, ry, w, h, 0, ATurn lineColor t) 81 82 ------------------------------------------------------------------------ 83 84 withTentacle :: Int -> Int -> Int -> Production -> Container 85 withTentacle rx ry direction prod = 86 (rx, ry, width, height, inOutY, AComposite [contents, theLine, theArrow]) 87 where (_, _, width1, height, inOutY, _) = contents 88 contents = makePicture rx1 0 direction prod 89 width = width1 + borderDistX 90 rx1 | direction > 0 = 0 91 | otherwise = borderDistX 92 theLine | direction > 0 = mkLine width1 inOutY borderDistX 0 93 | otherwise = mkLine 0 inOutY borderDistX 0 94 theArrow | direction > 0 = mkArrow width inOutY direction 95 | otherwise = mkArrow 0 inOutY direction 96 97 makePicture :: Int -> Int -> Int -> Production -> Container 98 99 makePicture rx ry direction (ProdProduction ntName ntAliases prod) = 100 (rx, ry, width, height, 0, AComposite ([content1, content2]++glue)) 101 where (_, _, width1, height1, inOutY1, _) = content1 102 content1 = withTentacle rx1 ry1 direction prod 103 content2@(_,_, width2, height2,_,_) = mkNonTerminal str rx2 ry2 104 rx1 = 2*borderDistX 105 ry1 = fatLineWidth `div` 2 106 rx2 = 0 107 ry2 = ry1 + height1 + distance - fontDescender ntFont 108 distance = 2*borderDistY 109 width = 2*borderDistX + max width1 width2 110 height = height1 +fatLineWidth + height2 + distance 111 glue = [ 112 mkLine 0 (ry1 + inOutY1) (2*borderDistX) 0, 113 mkArrow rx1 (ry1 + inOutY1) direction] 114 str = case ntAliases of 115 [] -> ntName 116 newName:_ -> newName 117 118 makePicture rx ry direction (ProdTerm [prod]) = 119 makePicture rx ry direction prod 120 makePicture rx ry direction (ProdTerm prods) = 121 (rx, ry, width, height, inOutY, AComposite (newcontents ++ glue)) 122 where newcontents = zip6 rxs rys widths heights inOutYs gobjs 123 (_, _, widths, heights, inOutYs, gobjs) = unzip6 contents 124 ncontents = length prods 125 -- sadly enough it's not possible to take rxs and rys in place of the fakes! 126 fakes = take ncontents (repeat 0) 127 contents = zipWith4 makePicture fakes fakes directions prods 128 height = sum heights + (ncontents-1) * borderDistY 129 maxwidth = maximum widths 130 width = maxwidth + 4 * borderDistX 131 rxs | direction > 0 = take ncontents (repeat (2 * borderDistX)) 132 | otherwise = map ((+ 2*borderDistX) . (maxwidth -)) widths 133 rys = tail (scanr f 0 heights) where f h q = h + q + borderDistY 134 directions = take ncontents (repeat direction) 135 entries = zipWith (+) rys inOutYs -- frame relative Y positions of entries 136 firstEntry = entries!!0 137 lastEntry = entries!!(ncontents-1) 138 middleEntries = init (tail entries) 139 inOutY = (firstEntry + lastEntry) `div` 2 140 inOutDiff = firstEntry - lastEntry - 2*borderDistY 141 glue = fixedglue ++ variableglue 142 fixedglue = [ 143 mkLine 0 inOutY borderDistX 0, 144 mkLine (width-borderDistX) inOutY borderDistX 0, 145 mkTurn borderDistX (firstEntry - borderDistY) borderDistX borderDistY SE, 146 mkTurn borderDistX lastEntry borderDistX borderDistY NE, 147 mkLine borderDistX (lastEntry + borderDistY) 0 inOutDiff, 148 mkTurn (width-2*borderDistX) (firstEntry - borderDistY) borderDistX borderDistY SW, 149 mkTurn (width-2*borderDistX) lastEntry borderDistX borderDistY WN, 150 mkLine (width-borderDistX) (lastEntry + borderDistY) 0 inOutDiff] ++ 151 map f middleEntries ++ 152 map g middleEntries 153 where f y = mkLine borderDistX y borderDistX 0 154 g y = mkLine (width-2*borderDistX) y borderDistX 0 155 variableglue | direction > 0 = zipWith g widths entries 156 | otherwise = zipWith h widths entries 157 where g w y = mkLine (2*borderDistX + w) y (maxwidth - w) 0 158 h w y = mkLine (2*borderDistX) y (maxwidth - w) 0 159 obsoleteglue = 160 map (f (2*borderDistX)) entries 161 where f x y = mkArrow x y direction 162 163 {- the following works for two terms, both directions 164 makePicture rx ry direction (ProdTerm [prod1, prod2]) 165 | direction > 0 = 166 let (_, _, width1, height1, inOutY1, _) = content1 167 content1 = makePicture rx1 ry1 direction prod1 168 (_, _, width2, height2, inOutY2, _) = content2 169 content2 = makePicture rx2 ry2 direction prod2 170 rx1 = 2*borderDistX 171 rx2 = 2*borderDistX 172 ry2 = 0 173 ry1 = height2 + borderDistY 174 maxwidth = max width1 width2 175 width = 4*borderDistX + maxwidth 176 height = height2 + borderDistY + height1 177 inOutY = (inOutY2 + ry1 + inOutY1) `div` 2 178 inOutDiff = ry1 + inOutY1 - inOutY2 - 2*borderDistY 179 glue = [ 180 mkLine 0 inOutY borderDistX 0, 181 mkLine (width - borderDistX) inOutY borderDistX 0, 182 mkLine borderDistX (ry2 + inOutY2 + borderDistY) 0 inOutDiff, 183 mkLine (width - borderDistX) (ry2 + inOutY2 + borderDistY) 0 inOutDiff, 184 mkTurn borderDistX (ry1 + inOutY1 - borderDistX) borderDistX borderDistY SE, 185 mkTurn borderDistX inOutY2 borderDistX borderDistY NE, 186 mkTurn (width - 2*borderDistX) (ry1 + inOutY1 - borderDistX) borderDistX borderDistY SW, 187 mkTurn (width - 2*borderDistX) inOutY2 borderDistX borderDistY WN, 188 mkLine (rx1 + width1) (ry1 + inOutY1) (maxwidth - width1) 0, 189 mkLine (rx2 + width2) (ry2 + inOutY2) (maxwidth - width2) 0] 190 in (rx, ry, width, height, inOutY, AComposite ([content1,content2]++glue)) 191 | otherwise = 192 let (_, _, width1, height1, inOutY1, _) = content1 193 content1 = makePicture rx1 ry1 direction prod1 194 (_, _, width2, height2, inOutY2, _) = content2 195 content2 = makePicture rx2 ry2 direction prod2 196 maxwidth = max width1 width2 197 width = 4*borderDistX + maxwidth 198 height = height2 + borderDistY + height1 199 inOutY = (inOutY2 + ry1 + inOutY1) `div` 2 200 inOutDiff = ry1 + inOutY1 - inOutY2 - 2*borderDistY 201 rx1 = 2*borderDistX + (maxwidth - width1) 202 rx2 = 2*borderDistX + (maxwidth - width2) 203 ry2 = 0 204 ry1 = height2 + borderDistY 205 glue = [ 206 mkLine 0 inOutY borderDistX 0, 207 mkLine (width - borderDistX) inOutY borderDistX 0, 208 mkLine borderDistX (ry2 + inOutY2 + borderDistY) 0 inOutDiff, 209 mkLine (width - borderDistX) (ry2 + inOutY2 + borderDistY) 0 inOutDiff, 210 mkTurn borderDistX (ry1 + inOutY1 - borderDistX) borderDistX borderDistY SE, 211 mkTurn borderDistX inOutY2 borderDistX borderDistY NE, 212 mkTurn (width - 2*borderDistX) (ry1 + inOutY1 - borderDistX) borderDistX borderDistY SW, 213 mkTurn (width - 2*borderDistX) inOutY2 borderDistX borderDistY WN, 214 mkLine (2*borderDistX) (ry1 + inOutY1) (maxwidth - width1) 0, 215 mkLine (2*borderDistX) (ry2 + inOutY2) (maxwidth - width2) 0] 216 in (rx, ry, width, height, inOutY, AComposite ([content1,content2]++glue)) 217 -} 218 219 makePicture rx ry direction (ProdFactor [prod]) = 220 makePicture rx ry direction prod 221 {- 222 makePicture rx ry direction (ProdFactor prods) = 223 (rx, ry, width, height, inOutY, AComposite (glue++contents)) 224 where (_, _, widths, heights, inOutYs, gobjs) = unzip6 contents 225 contents = zipWith4 makePicture rxs rys directions prods 226 ncontents = length prods 227 aboves = zipWith (-) heights inOutYs 228 maxIO = maximum inOutYs 229 height = maxIO + maximum aboves 230 width = sum widths + (ncontents-1)*borderDistX 231 inOutY = maxIO 232 rxs 233 -- = take ncontents [0, 20*borderDistX .. ] 234 | direction > 0 = init (scanl f 0 widths) 235 | otherwise = tail (scanr f 0 widths) 236 where f q w = q + w + borderDistX 237 238 rys = 239 take ncontents (repeat 0) 240 -- map (inOutY -) inOutYs 241 directions = take ncontents (repeat direction) 242 glue | direction > 0 = map f (tail rxs) 243 | otherwise = map f (init rxs) 244 where f x = mkLine (x-borderDistX) inOutY borderDistX 0 245 -} 246 247 makePicture rx ry direction (ProdFactor [prod1,prod2]) 248 | direction > 0 = 249 let (_, _, width1, height1, inOutY1, _) = content1 250 content1 = withTentacle rx1 ry1 direction prod1 251 (_, _, width2, height2, inOutY2, _) = content2 252 content2 = makePicture rx2 ry2 direction prod2 253 rx1 = 0 254 rx2 = width1 255 width = width1 + width2 256 inOutY = max inOutY1 inOutY2 257 ry1 = inOutY - inOutY1 258 ry2 = inOutY - inOutY2 259 height = inOutY + max (height1 - inOutY1) (height2 - inOutY2) 260 in (rx, ry, width, height, inOutY, AComposite ([content1,content2])) 261 | otherwise = 262 let (_, _, width1, height1, inOutY1, _) = content1 263 content1 = withTentacle rx1 ry1 direction prod1 264 (_, _, width2, height2, inOutY2, _) = content2 265 content2 = makePicture rx2 ry2 direction prod2 266 rx2 = 0 267 rx1 = width2 268 width = width1 + width2 269 inOutY = max inOutY1 inOutY2 270 ry1 = inOutY - inOutY1 271 ry2 = inOutY - inOutY2 272 height = inOutY + max (height1 - inOutY1) (height2 - inOutY2) 273 in (rx, ry, width, height, inOutY, AComposite ([content1,content2])) 274 275 makePicture rx ry direction (ProdFactor (prod:prods)) = 276 makePicture rx ry direction (ProdFactor [prod, ProdFactor prods]) 277 -- this is a ghastly hack! 278 279 makePicture rx ry direction (ProdNonterminal str) = 280 mkBox rx ry width height inOutY content 281 where content@(_,_,width', height',_,_) = mkNonTerminal str rx' ry' 282 width = width' + 2*borderDistX + 2*fatLineWidth 283 height = height' + borderDistY + 2*fatLineWidth 284 rx' = fatLineWidth + borderDistX 285 ry' = fatLineWidth + borderDistY `div` 2 - fontDescender ntFont 286 inOutY = height `div` 2 287 288 makePicture rx ry direction (ProdTerminal str) = 289 mkRoundBox rx ry width height inOutY content 290 where content@(_,_,width', height',_,_) = mkTerminal str rx' ry' 291 width = width' + 2*borderDistX + 2*fatLineWidth 292 height = height' + borderDistY + 2*fatLineWidth 293 rx' = fatLineWidth + borderDistX 294 ry' = fatLineWidth + borderDistY `div` 2 - fontDescender tFont 295 inOutY = height `div` 2 296 297 makePicture rx ry direction (ProdOption prod) = 298 (rx, ry, width, height, inOutY, AComposite (content:glue)) 299 where (_, _, width', height', inOutY', gobj) = content 300 content = makePicture rx' ry' direction prod 301 width = width' + 6*borderDistX 302 height = height' + borderDistY 303 rx' = 3*borderDistX 304 ry' = borderDistY 305 inOutY = 0 306 glue = variableglue ++ fixedglue 307 fixedglue = [ 308 mkLine 0 0 width 0, 309 mkTurn 0 0 borderDistX bby WN, 310 mkTurn borderDistX (inOutY'+borderDistY-bby) borderDistX bby SE, 311 mkLine (2*borderDistX) (ry'+inOutY') borderDistX 0, 312 mkTurn (width-borderDistX) 0 borderDistX bby NE, 313 mkTurn (width-2*borderDistX) (inOutY'+borderDistY-bby) borderDistX bby SW, 314 mkLine (width-3*borderDistX) (ry'+inOutY') borderDistX 0, 315 mkLine borderDistX bby 0 (inOutY'+borderDistY-2*bby), 316 mkLine (width-borderDistX) bby 0 (inOutY'+borderDistY-2*bby)] 317 where bby = min borderDistY ((inOutY'+borderDistY) `div` 2) 318 variableglue 319 | direction > 0 = [mkArrow (3*borderDistX) (ry'+inOutY') direction] 320 | otherwise = [mkArrow (width-3*borderDistX) (ry'+inOutY'+borderDistY) direction] 321 322 makePicture rx ry direction (ProdRepeat prod) = 323 (rx, ry, width, height, inOutY, AComposite (content:glue)) 324 where (_, _, width', height', inOutY', gobj) = content 325 content = makePicture rx' ry' (-direction) prod 326 width = width' + 4*borderDistX 327 height = height' + borderDistY 328 rx' = 2*borderDistX 329 ry' = borderDistY 330 inOutY = 0 331 glue = variableglue ++ fixedglue 332 fixedglue = [ 333 mkLine 0 0 width 0, 334 mkTurn borderDistX 0 borderDistX bby NE, 335 mkTurn borderDistX (inOutY'+borderDistY-bby) borderDistX bby SE, 336 mkTurn (width-2*borderDistX) 0 borderDistX bby WN, 337 mkTurn (width-2*borderDistX) (inOutY'+borderDistY-bby) borderDistX bby SW, 338 mkLine borderDistX bby 0 (inOutY'+borderDistY-2*bby), 339 mkLine (width-borderDistX) bby 0 (inOutY'+borderDistY-2*bby)] 340 where bby = min borderDistY ((inOutY'+borderDistY) `div` 2) 341 variableglue 342 | direction < 0 = [mkArrow (2*borderDistX) (inOutY'+borderDistY) (-direction)] 343 | otherwise = [mkArrow (width-2*borderDistX) (inOutY'+borderDistY) (-direction)] 344 345 makePicture rx ry direction (ProdRepeat1 prod) = 346 (rx, ry, width, height, inOutY, AComposite (content:glue)) 347 where (_, _, width', height', inOutY', gobj) = content 348 content = makePicture rx' ry' (direction) prod 349 width = width' + 4*borderDistX 350 height = height' + borderDistY 351 rx' = 2*borderDistX 352 ry' = 0 353 inOutY = inOutY' 354 glue = [ 355 mkLine 0 inOutY rx' 0, 356 mkLine (rx'+width') inOutY rx' 0, 357 mkTurn borderDistX inOutY borderDistX borderDistY NE, 358 mkTurn borderDistX (height-borderDistY) borderDistX borderDistY SE, 359 mkTurn (width-rx') inOutY borderDistX borderDistY WN, 360 mkTurn (width-rx') (height-borderDistY) borderDistX borderDistY SW, 361 mkLine borderDistX (inOutY+borderDistY) 0 (height'-inOutY'-borderDistY), 362 mkLine (width-borderDistX) (inOutY+borderDistY) 0 (height'-inOutY'-borderDistY), 363 mkLine rx' height width' 0, 364 mkArrow (rx'+width' `div` 2) height (-direction)] 365 366 makePicture rx ry direction (ProdRepeatWithAtom prod1 prod2) = 367 (rx, ry, width, height, inOutY, AComposite (content1:content2:glue)) 368 where (_, _, width1, height1, inOutY1, _) = content1 369 (_, _, width2, height2, inOutY2, _) = content2 370 content1 = makePicture rx1 ry1 direction prod1 371 content2 = makePicture rx2 ry2 (-direction) prod2 372 maxwidth = max width1 width2 373 width = maxwidth + 4*borderDistX 374 height = height1 + height2 + borderDistY 375 adjx1 = (maxwidth - width1) `div` 2 376 rx1 = 2*borderDistX + adjx1 377 ry1 = 0 378 adjx2 = (maxwidth - width2) `div` 2 379 rx2 = 2*borderDistX + adjx2 380 ry2 = height1 + borderDistY 381 inOutY = inOutY1 382 glue = variableglue ++ fixedglue 383 fixedglue = [ 384 mkLine 0 inOutY rx1 0, 385 mkLine (rx1 + width1) inOutY rx1 0, 386 mkLine (2*borderDistX) (ry2+inOutY2) adjx2 0, 387 mkLine (2*borderDistX + adjx2 + width2) (ry2+inOutY2) adjx2 0, 388 mkTurn borderDistX inOutY borderDistX borderDistY NE, 389 mkTurn borderDistX (ry2+inOutY2-borderDistY) borderDistX borderDistY SE, 390 mkTurn (rx1+width1+adjx1) inOutY borderDistX borderDistY WN, 391 mkTurn (rx1+width1+adjx1) (ry2+inOutY2-borderDistY) borderDistX borderDistY SW, 392 mkLine borderDistX (inOutY+borderDistY) 0 (height1-inOutY1 + inOutY2 - borderDistY), 393 mkLine (rx1+width1+adjx1+borderDistX) (inOutY+borderDistY) 0 (height1-inOutY1 + inOutY2 - borderDistY)] 394 variableglue 395 | direction > 0 = [mkArrow (2*borderDistX + adjx2 + width2) (ry2+inOutY2) (-direction)] 396 | otherwise = [mkArrow (2*borderDistX + adjx2) (ry2+inOutY2) (-direction)] 397 398