gulcii-0.2.0.1: src/Layout.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 Layout (Term(..), Coords, Layout(..), layout, coordinates) where

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

import qualified Graph as G
import Evaluation (Strategy(..))

type Coords = (Integer, Integer)

data Term
  = Free String Coords
  | Bound Integer Coords
  | Lambda Strategy Term Coords
  | Apply Term Term Coords
  | RefInst Integer Term Coords
  | Reference Integer Coords
  | Trace String Term Term Coords
  deriving (Read, Show, Eq, Ord)

data Layout = Layout Term Integer Integer (Map Integer Coords)
  deriving (Read, Show, Eq, Ord)

coordinates :: Term -> Coords
coordinates (Free      _ xy) = xy
coordinates (Bound     _ xy) = xy
coordinates (Lambda  _ _ xy) = xy
coordinates (Apply   _ _ xy) = xy
coordinates (RefInst _ _ xy) = xy
coordinates (Reference _ xy) = xy
coordinates (Trace _ _ _ xy) = xy

layout :: G.Term -> G.References -> Layout
layout = layout' (0, 0) M.empty

layout' :: Coords -> Map Integer Coords -> G.Term -> G.References -> Layout
layout' xy ps (G.Free v) _ = Layout (Free v xy) 1 1 ps
layout' xy ps (G.Bound v) _ = Layout (Bound v xy) 1 1 ps
layout' (x,y) ps (G.Lambda k t) g = let Layout lt w h ps' = layout' (x, y + 1) ps t g
                                        (px, _) = coordinates lt
                                    in  Layout (Lambda k lt (px, y)) w (h + 1) ps'
layout' (x,y) ps (G.Apply a b) g = let Layout la aw ah psa = layout' (x, y + 1) ps a g
                                       Layout lb bw bh psb = layout' (x + aw + 1, y + 1) psa b g
                                   in  Layout (Apply la lb (x + aw, y)) (1 + aw + bw) (1 + (ah `max` bh)) psb
layout' xy@(x,y) ps (G.Reference p) g = if p `M.member` ps
                                 then Layout (Reference p xy) 1 1 ps
                                 else case M.lookup p g of
                                        Nothing -> error $ "layout': bad pointer: " ++ show p
                                        Just t  -> let Layout lt w h pst = layout' (x, y + 1) ps t g
                                                       (px, py) = coordinates lt
                                                   in Layout (RefInst p lt (px, y)) w (1 + h) (M.insert p (px, py) pst)
layout' (x,y) ps (G.Trace s a b) g =
  let Layout la aw ah psa = layout' (x, y + 1) ps a g
      Layout lb bw bh psb = layout' (x + aw + 1, y + 1) psa b g
  in  Layout (Trace s la lb (x + aw, y)) (1 + aw + bw) (1 + (ah `max` bh)) psb