gulcii-0.3: src/Layout.hs

{-
    gulcii -- graphical untyped lambda calculus interpreter
    Copyright (C) 2011, 2013, 2017  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, Counts(..), counts) 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
  | Bound0 Coords
  | Scope Term Coords
  | Lambda Strategy Term Coords
  | Apply Term Term Coords
  | RefInst Integer Term Coords
  | Reference Integer 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 (Bound0      xy) = xy
coordinates (Scope     _ xy) = xy
coordinates (Lambda  _ _ xy) = xy
coordinates (Apply   _ _ xy) = xy
coordinates (RefInst _ _ xy) = xy
coordinates (Reference _ 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.Bound0) _ =
  Layout (Bound0 xy) 1 1 ps
layout' (x, y) ps (G.Scope t) g =
  let Layout lt w h ps' = layout' (x, y + 1) ps t g
      (px, _) = coordinates lt
  in  Layout (Scope lt (px, y)) w (h + 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)

data Counts = Counts
  { nFree, nBound0, nScope, nLambda, nApply, nRefInst, nReference :: !Int }

instance Monoid Counts where
  mempty = Counts 0 0 0 0 0 0 0
  mappend c d = Counts
                  { nFree = nFree c + nFree d
                  , nBound0 = nBound0 c + nBound0 d
                  , nScope = nScope c + nScope d
                  , nLambda = nLambda c + nLambda d
                  , nApply = nApply c + nApply d
                  , nRefInst = nRefInst c + nRefInst d
                  , nReference = nReference c + nReference d
                  }

counts :: Term -> Counts
counts (Free _ _) = mempty{ nFree = 1 }
counts (Bound0 _) = mempty{ nBound0 = 1 }
counts (Scope t _) =  let c = counts t in c{ nScope = nScope c + 1 }
counts (Lambda _ t _) = let c = counts t in c{ nLambda = nLambda c + 1 }
counts (Apply a b _) = let c = counts a ; d = counts b in mappend c d
counts (RefInst _ t _) = let c = counts t in c{ nRefInst = nRefInst c + 1 }
counts (Reference _ _) = mempty{ nReference = 1 }