gulcii-0.2.0.1: src/Draw.hs

{-
    gulcii -- graphical untyped lambda calculus interpreter
    Copyright (C) 2011, 2013  Claude Heiland-Allen

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License along
    with this program; if not, write to the Free Software Foundation, Inc.,
    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-}

module Draw (draw) where

import Data.List (genericDrop)
import qualified Data.Map.Strict as M
import Data.Map.Strict (Map)

import Graphics.Rendering.Cairo

import qualified Layout as L
import Evaluation (Strategy(..))

type RGB = (Double, Double, Double)

colour :: L.Term -> RGB
colour (L.Free      _ _) = (0, 0.5, 1)
colour (L.Bound     _ _) = (0.5, 0, 1)
colour (L.Lambda Strict _ _) = (1, 0, 0)
colour (L.Lambda Lazy   _ _) = (1, 0, 0.5)
colour (L.Lambda Copy   _ _) = (1, 0, 1)
colour (L.Apply   _ _ _) = (1, 0.5, 0)
colour (L.RefInst _ _ _) = (0.5, 1, 0)
colour (L.Reference _ _) = (0, 1, 0.5)
colour (L.Trace _ _ _ _) = (1, 1, 0)

circle :: L.Coords -> RGB -> Render ()
circle (x, y) (r, g, b) = do
  save
  translate (fromIntegral x) (fromIntegral y)
  arc 0 0 0.365 0 (2*pi)
  setSourceRGB r g b
  fillPreserve
  setSourceRGB 0 0 0
  stroke
  restore

line :: L.Coords -> L.Coords -> Render ()
line (x, y) (x', y') = do
  save
  moveTo (fromIntegral x ) (fromIntegral y )
  lineTo (fromIntegral x') (fromIntegral y')
  stroke
  restore

draw :: Double -> Double -> L.Layout -> Render ()
draw ww0 hh0 (L.Layout t w h ps) = do
  save
  translate dx dy
  scale s s
  translate 0.5 0.5
  setLineWidth 0.1
  setSourceRGB 0 0 0
  drawLinks ps t
  drawNodes t
  setLineCap LineCapRound
  setSourceRGB 0.5 0.5 0.5
  drawVLinks [] t
  setFontSize (6 / sqrt s)
  translate 0 0.5
  drawNames t
  setSourceRGB 0 0 0
  fillPreserve
  setLineWidth (0.2 / sqrt s)
  setSourceRGB 1 1 1
  stroke
  restore
  where
    s = if fromIntegral w * hh <= fromIntegral h * ww then hh / fromIntegral h else ww / fromIntegral w
    ww = ww0 - 128
    hh = hh0 - 64
    dx = (ww0 - s * fromIntegral w) / 2
    dy = (hh0 - s * fromIntegral h) / 2

drawNames :: L.Term -> Render ()
drawNames (L.Free s (x,y)) = do
  e <- textExtents s
  moveTo (fromIntegral x - textExtentsWidth e / 2) (fromIntegral y)
  textPath s
drawNames (L.Bound _ _) = return ()
drawNames (L.Lambda _ t _) = drawNames t
drawNames (L.Apply a b _) = drawNames a >> drawNames b
drawNames (L.RefInst _ t _) = drawNames t
drawNames (L.Reference _ _) = return ()
drawNames (L.Trace s a b (x,y)) = do
  e <- textExtents s
  moveTo (fromIntegral x - textExtentsWidth e / 2) (fromIntegral y)
  textPath s
  drawNames a
  drawNames b

drawLinks :: Map Integer L.Coords -> L.Term -> Render ()
drawLinks _  (L.Free _ _) = return ()
drawLinks _  (L.Bound _ _) = return ()
drawLinks ps (L.Lambda _ t xy) = let x'y' = L.coordinates t
                                 in line xy x'y' >> drawLinks ps t
drawLinks ps (L.Apply a b xy) = let axay = L.coordinates a
                                    bxby = L.coordinates b
                                in line xy axay >> line xy bxby >> drawLinks ps a >> drawLinks ps b
drawLinks ps (L.RefInst _ t xy) = let x'y' = L.coordinates t
                                  in line xy x'y' >> drawLinks ps t
drawLinks ps (L.Reference p xy) = let Just x'y' = M.lookup p ps
                                  in line xy x'y'
drawLinks ps (L.Trace _ a b xy) =
  let axay = L.coordinates a
      bxby = L.coordinates b
  in  line xy axay >> line xy bxby >> drawLinks ps a >> drawLinks ps b

drawVLinks :: [L.Coords] -> L.Term -> Render ()
drawVLinks ls (L.Bound n xy) =
  case genericDrop n ls of
    [] -> return ()
    x'y':_ -> line xy x'y'
drawVLinks ls (L.Lambda _ t xy) = drawVLinks (xy : ls) t
drawVLinks ls (L.Apply  s t _) = drawVLinks ls s >> drawVLinks ls t
drawVLinks ls (L.RefInst _ t _) = drawVLinks ls t
drawVLinks ls (L.Trace _ s t _) = drawVLinks ls s >> drawVLinks ls t
drawVLinks _ _ = return ()

drawNodes :: L.Term -> Render ()
drawNodes n@(L.Free      _ _) = drawNode n
drawNodes n@(L.Bound     _ _) = drawNode n
drawNodes n@(L.Lambda  _ t _) = drawNode n >> drawNodes t
drawNodes n@(L.Apply   a b _) = drawNode n >> drawNodes a >> drawNodes b
drawNodes n@(L.RefInst _ t _) = drawNode n >> drawNodes t
drawNodes n@(L.Reference _ _) = drawNode n
drawNodes n@(L.Trace _ a b _) = drawNode n >> drawNodes a >> drawNodes b

drawNode :: L.Term -> Render ()
drawNode n = circle (L.coordinates n) (colour n)