graph-rewriting-lambdascope-0.5: Main.hs

{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}
module Main where

import Prelude.Unicode
import Data.List (delete)
import GraphRewriting.Graph
import GraphRewriting.GL.Render
import GraphRewriting.GL.UI as UI
import Term (parseFile)
import Resolver (resolve)
import Graph
import GL ()
import Rules
import GraphRewriting.Rule
import GraphRewriting.Pattern
import GraphRewriting.Graph.Read
import GraphRewriting.Graph.Write.Unsafe as Unsafe
import GraphRewriting.Layout.Coulomb
import GraphRewriting.Layout.SpringEmbedder
import GraphRewriting.Layout.Gravitation
import GraphRewriting.Layout.Wrapper as Layout

import GraphRewriting.Strategies.Control as Control
import GraphRewriting.Strategies.LeftmostOutermost


instance Render n ⇒ Render (Layout.Wrapper n) where render = render . wrappee
instance PortSpec n ⇒ PortSpec (Control.Wrapper n) where portSpec = portSpec . wrapped
instance LeftmostOutermost n ⇒ LeftmostOutermost (Layout.Wrapper n) where lmoPort = lmoPort . wrappee


main ∷ IO ()
main = do
	(prog,args) ← UI.initialise
	let lmo = "--lmo" ∈ args
	args ← return $ "--lmo" `delete` args
	file ← case args of
		[f] → return f
		___ → error "usage: lambdascope [GLUT-options] [--lmo] <file>"
	term ← parseFile file
	let hypergraph = execGraph (apply $ exhaustive compileShare) (resolve term)
	let layoutGraph = Layout.wrapGraph hypergraph

	if lmo
		then UI.run 50 id layoutStep (Control.wrapGraph layoutGraph) (lmoTree ruleTree)
		else UI.run 50 id layoutStep layoutGraph ruleTree

-- | Modifies the rules of the rule tree with a given function.
-- This can be used to for example wrap a strategy rule around the existing rules.
mapRules :: (n -> m) -> LabeledTree n -> LabeledTree m
mapRules f (Leaf n r)    = Leaf n (f r)
mapRules f (Branch n rs) = Branch n (map (mapRules f) rs)

-- Appends a rule to the top branch of a rule tree
appendRule :: n -> LabeledTree n -> LabeledTree n
appendRule r l@(Leaf n rr) = Branch n [l, Leaf "moveControl" r]
appendRule r (Branch n rs) = Branch n (rs ++ [Leaf "moveControl" r])

-- layoutStep :: (View Rotation n, View [Port] n, View Position n) => n -> IO ()
layoutStep n = do
	(cgf, cf, sf, rot) ← readOnly $ do
		cgf ← centralGravitation n
		cf ← coulombForce n
		sf ← springForce 1.5 n
		rot ← angularMomentum n
		return (cgf, cf, sf, rot)
	Unsafe.adjustNode n $ Position . sf (\x → min 10 (x*0.9)) . cgf (\x → min 10 (x*0.01)) . cf (\x → min 10 (100/(x^2+0.1))) . position
	Unsafe.adjustNode n $ rot (*0.9)

lmoTree ∷ (LeftmostOutermost n, View [Port] n, View Control n) ⇒ LabeledTree (Rule n) -> LabeledTree (Rule n)
lmoTree = appendRule moveControl . mapRules leftmostOutermost

ruleTree :: (View NodeLS n, View [Port] n) => LabeledTree (Rule n)
ruleTree = Branch "All"
	[Leaf "Beta Reduction" beta,
	 Branch "All but Beta"
	 	[Leaf "Duplicate" duplicate,
	 	 Leaf "Eliminate" (eliminateDelimiterEraser <|> eliminateDelimiterConstant <|> eliminateDuplicator),
	 	 Leaf "Annihilate" annihilate,
	 	 Leaf "Commute Delimiter" commuteDelimiter,
	 	 Leaf "Erase" eraser,
		 Leaf "Case" caseNode,
	 	 Branch "Primitive"
			[Leaf "Constant" applyConstant,
			 Leaf "Apply Operator" applyOperator,
			 Leaf "Exec Operator" execOperator,
			 Leaf "Reduce Operator Args" reduceOperatorArgs]]]