simplify

simplify

import "../src/LangPrelude.prg" (maybeM)

kind Inventory = Empty | More Inventory Nat deriving LeftList(i)

data NatList :: Inventory ~> * where
  Nope :: NatList []i
  Augment :: NatList i -> Nat' n -> NatList [i; n]i
 deriving LeftList(nl)

data LeftThrist :: forall (l :: *1) . (l ~> l ~> *)  ~> l ~> l ~> * where
  LNil :: LeftThrist k a a
  LCons :: LeftThrist k a b -> k b c -> LeftThrist k a c
 deriving LeftList(lt)

data Elem :: Inventory ~> Inventory ~> * where
  Single :: NatList nl -> Elem i {merge i nl}

monad maybeM

merge :: Inventory ~> Inventory ~> Inventory
{merge []i i} = i
{merge [as; a]i []i} = [as; a]i
{merge [as; a]i [bs; b]i} = {arrange as bs a b a b}

mergeNL :: NatList i -> NatList j -> Maybe (NatList {merge i j})
mergeNL []nl j = Just j
mergeNL (i@[as; a]nl) []nl = Just i
mergeNL [as; a]nl [bs; b]nl = arrNL as bs a b a b
mergeNL _ _ = Nothing

arrange :: Inventory ~> Inventory ~> Nat ~> Nat ~> Nat ~> Nat ~> Inventory
{arrange i j 0t (1+b')t a b} = [{merge [i; a]i j}; b]i
{arrange i j (1+a')t 0t a b} = [{merge i [j; b]i}; a]i
{arrange i j (1+a')t (1+b')t a b} = {arrange i j a' b' a b}

arrNL :: NatList i -> NatList j -> Nat' a' -> Nat' b' -> Nat' a -> Nat' b -> Maybe (NatList {arrange i j a' b' a b})
arrNL i j 0v (1+b')v a b = do { iaj <- mergeNL [i; a]nl j; return [iaj; b]nl }
arrNL i j (1+a')v 0v a b = do { ijb <- mergeNL i [j; b]nl; return [ijb; a]nl }
arrNL i j (1+a')v (1+b')v a b = arrNL i j a' b' a b
arrNL _ _ _ _ _ _ = Nothing

join :: NatList i -> LeftThrist Elem []i i -> NatList j -> Maybe (LeftThrist Elem []i {merge i j}, NatList {merge i j})
join i thr j = do { ij <- mergeNL i j
                  ; return ([thr; Single j]lt, ij) }

Just (t1, e1) = let start = [0v, 2v, 4v]nl in join start [Single start]lt [3v]nl
Just (t2, e2) = join e1 t1 [1v, 5v]nl

import "../src/LangPrelude.prg" (maybeM)

kind Inventory = Empty | More Inventory Nat deriving LeftList(i)

data NatList :: Inventory ~> * where
  Nope :: NatList []i
  Augment :: NatList i -> Nat' n -> NatList [i; n]i
 deriving LeftList(nl)

data LeftThrist :: forall (l :: *1) . (l ~> l ~> *)  ~> l ~> l ~> * where
  LNil :: LeftThrist k a a
  LCons :: LeftThrist k a b -> k b c -> LeftThrist k a c
 deriving LeftList(lt)

data Elem :: Inventory ~> Inventory ~> * where
  Single :: NatList nl -> Elem i {merge i nl}

monad maybeM

merge :: Inventory ~> Inventory ~> Inventory
{merge []i i} = i
{merge [as; a]i []i} = [as; a]i
{merge [as; a]i [bs; b]i} = {arrange as bs a b a b}

mergeNL :: NatList i -> NatList j -> Maybe (NatList {merge i j})
mergeNL []nl j = Just j
mergeNL (i@[as; a]nl) []nl = Just i
mergeNL [as; a]nl [bs; b]nl = arrNL as bs a b a b
mergeNL _ _ = Nothing

arrange :: Inventory ~> Inventory ~> Nat ~> Nat ~> Nat ~> Nat ~> Inventory
{arrange i j 0t (1+b')t a b} = [{merge [i; a]i j}; b]i
{arrange i j (1+a')t 0t a b} = [{merge i [j; b]i}; a]i
{arrange i j (1+a')t (1+b')t a b} = {arrange i j a' b' a b}

arrNL :: NatList i -> NatList j -> Nat' a' -> Nat' b' -> Nat' a -> Nat' b -> Maybe (NatList {arrange i j a' b' a b})
arrNL i j 0v (1+b')v a b = do { iaj <- mergeNL [i; a]nl j; return [iaj; b]nl }
arrNL i j (1+a')v 0v a b = do { ijb <- mergeNL i [j; b]nl; return [ijb; a]nl }
arrNL i j (1+a')v (1+b')v a b = arrNL i j a' b' a b
arrNL _ _ _ _ _ _ = Nothing

join :: NatList i -> LeftThrist Elem []i i -> NatList j -> Maybe (LeftThrist Elem []i {merge i j}, NatList {merge i j})
join i thr j = do { ij <- mergeNL i j
                  ; return ([thr; Single j]lt, ij) }

Just (t1, e1) = join [0v, 2v, 4v]nl [Single [0v, 2v, 4v]nl]lt [3v]nl
Just (t2, e2) = join e1 t1 [1v, 5v]nl


WIP: fix some ugly blunders

WIP: fix some ugly blunders

-- Modeling Opetopes
-- here is Eric's editor: http://sma.epfl.ch/~finster/opetope/opetope.html
--
-- Note: Kock et al. use a similar scheme, where
--          - dots    <-->   lines
--          - spheres <-->   dots
--          - lines disappear
--          -                spheres appear

-- Note: In Eric's new work (at IAS) there are no
--       dots any more, instead he uses 'outout cards', so
--          - (output) cards   <-->  lines
--          - space between stacked cards <--> output cards
--          - lines disappear
--          -                (regular) cards appear

import "../tests/NatList.prg"

-- list kind
--kind List = Ni | Co

-- define the Tree kind, a rose tree
-- note: Ni may only appear in Fork second position (TODO: use GADT!)

kind Tree = Unit | Ni | Fork Tree Tree deriving syntax (tr) List(Ni, Fork) Unit(Unit)

-- make it singleton

data Tree' :: Tree ~> * where
  In :: Tree' ()tr
  Fork :: Tree' head -> Tree' tail -> Tree' [head; tail]tr
  Done :: Tree' []tr

-- define a proposition for subtrees
-- to be checked: TakeHead must ensure that all the node is consumed

prop Subtree :: Tree ~> Tree ~> * where
  BothUnit :: Subtree ()tr ()tr
  BothNil :: Subtree []tr []tr
  TakeHead :: Subtree head head' -> Subtree tail tail' -> Subtree [head; tail]tr [head'; tail']tr
  SkipHead :: Subtree tail tail' -> Subtree [head; tail]tr [head'; tail']tr

-- now we can stack cards (these are zooms in Kock et al. parlance)

data Stack :: Tree ~> Tree ~> * where
  Empty :: Corolla tr => Tree' tr -> Stack tr ()tr
  SubDone :: Stack ()tr []tr
  Subdivision :: Stack ()tr sub -> Stack tr rest -> Stack tr [sub; rest]tr
  Encompass :: Subtree consumed tr => Stack consumed prod -> Stack tr prod
  -- the following three grab a node (and possibly its offsprings) and incorporate it into a single card
  -- (which is assumed to be open); [perhaps, note: there may be other cards stacked on this one]
  NodeDone :: Stack []tr [()tr]tr
  Pick :: {- EntireNode => -} Stack head prodhead -> Stack tail prodtail -> Stack [head; tail]tr [prodhead; prodtail]tr
  Exclude :: {- EntireNode => -} Stack tail prod -> Stack [()tr; tail]tr prod
  -- we need a way to sequence cards
  -- MultiCard :: ??? Disjoint a b 0 => Subtree a -> Subtree b -> Stack tr a [proda, prodb]tr

-- it remains to define corollas

prop Corolla :: Tree ~> * where
  None' :: Corolla []tr
  One' :: Corolla tail -> Corolla [()tr; tail]tr

--  o   --->  |
--  |         |

lolliCell :: Stack []tr ()tr
lolliCell = Empty Done

--  |         |
--  o   --->  |
--  |         |

dolliCell :: Stack [()tr]tr ()tr
dolliCell = Empty $ Fork In Done

--              |
--  [o]   --->  o
--   |          |

lolliFrame :: Stack []tr [()tr]tr
lolliFrame = Encompass NodeDone

--   |          |
--  [o]   --->  o
--   |          |

dolliFrame :: Stack [()tr]tr [()tr]tr
dolliFrame = Encompass (Exclude NodeDone)

--    |           o   |
-- | [o] |  --->   \ /
-- | [|] |          o
--    |             |

--cyclops :: Stack [()tr]tr [[]tr, ()tr]tr
--cyclops = Subdivision SubDone (Exclude NodeDone)

--- OLD IMPLEMENTATION FOLLOWS

-- Node Types

kind NodeType = Regular | Universal

-- Node Labels (parametrized by dimension?)

data NodeLabel = Named (Label n)
               | Comp NodeLabel NodeLabel

-- Node: named faces as inputs and an output (face)

-- Consuming some twig

data Eat :: Twig ~> * where
  NoDot :: Eat None  -- do not extend till next sprouting point
  Sub :: Eat (Sprout l)

-- A connected deck of cards

data Deck :: Twig ~> Twig ~> * where
  Air :: Deck t None
  Card :: Eat t -> Deck subt out -> Deck t (Sprout [out]w)

-- A forest: trees in each dimension up to n
--   o when it ends in a corolla then it is a cell (n-dimensional)
--

--data Forest

-- Idea: each tree must have two type parameters
--       o left: set of nodes from dim (n - 1) is our (tree of) lines
--       o right: my set of nodes is the tree I push to dim n + 1

-- HAH! we have a thrist!

-- trees live at the type level

-- have these forms
--      O  |
--   o  |  o
--      o

--         |
-- List of o starts at O

data List :: *1 where
  No :: List
  Ext :: List ~> Twig ~> List
 deriving LeftList(w)

data Twig :: *1 where
  None :: Twig
  Sprout :: List ~> Twig

-- an Opetope is a LeftThrist of Decks

-- Dimension Zero is always:

dim0 = Card NoDot Air

dim1 = Card Sub Air

upto1 = [dim0, dim1]lt

-- Modeling Opetopes
-- here is Eric's editor: http://sma.epfl.ch/~finster/opetope/opetope.html
--
-- Note: Kock et al. use a similar scheme, where
--          - dots    <-->   lines
--          - spheres <-->   dots
--          - lines disappear
--          -                spheres appear

-- Note: In Eric's new work (at IAS) there are no
--       dots any more, instead he uses 'outout cards', so
--          - (output) cards   <-->  lines
--          - space between stacked cards <--> output cards
--          - lines disappear
--          -                (regular) cards appear

import "../tests/NatList.prg"

-- list kind
--kind List = Ni | Co

-- define the Tree kind, a rose tree
-- note: Ni may only appear in Fork second position (TODO: use GADT!)

kind Tree = Unit | Ni | Fork Tree Tree deriving syntax (tr) List(Ni, Fork) Unit(Unit)

-- make it singleton

data Tree' :: Tree ~> * where
  In :: Tree' ()tr
  Fork :: Tree' head -> Tree' tail -> Tree' [head; tail]tr
  Done :: Tree' []tr

-- define a proposition for subtrees
-- to be checked: TakeHead must ensure that all the node is consumed

prop Subtree :: Tree ~> Tree ~> * where
  BothUnit :: Subtree ()tr ()tr
  BothNil :: Subtree []tr []tr
  TakeHead :: Subtree head head' -> Subtree tail tail' -> Subtree [head; tail]tr [head'; tail']tr
  SkipHead :: Subtree tail tail' -> Subtree [head; tail]tr [head'; tail']tr

-- now we can stack cards (these are zooms in Kock et al. parlance)

data Stack :: Tree ~> Tree ~> * where
  Empty :: Corolla tr => Tree' tr -> Stack tr ()tr
  SubDone :: Stack ()tr []tr
  Subdivision :: Stack ()tr sub -> Stack tr rest -> Stack tr [sub; rest]tr
  Encompass :: Subtree consumed tr => Stack consumed prod -> Stack tr prod
  -- the following three grab a node (and possibly its offsprings) and incorporate it into a single card
  -- there may be other cards stacked on this one
  NodeDone :: Stack []tr []tr
  Pick :: {- EntireNode => -} Stack head prodhead -> Stack tail prodtail -> Stack [head, tail]tr [prodhead, prodtail]tr
  Exclude :: {- EntireNode => -} Stack tail prod -> Stack [head, tail]tr prod
  -- we need a way to sequence cards
  -- MultiCard :: ??? Disjoint a b 0 => Subtree a -> Subtree b -> Stack tr a [proda, prodb]tr

-- it remains to define corollas

prop Corolla :: Tree ~> * where
  None' :: Corolla []tr
  One' :: Corolla tail -> Corolla [()tr; tail]tr

--  o   --->  |
--  |         |

lolliCell :: Stack []tr ()tr
lolliCell = Empty Done

--  |         |
--  o   --->  |
--  |         |

dolliCell :: Stack [()tr]tr ()tr
dolliCell = Empty $ Fork In Done

--    |           o   |
-- | [o] |  --->   \ /
-- | [|] |          o
--    |             |

--cyclops :: Stack [()tr]tr [[]tr, ()tr]tr
--cyclops = Subdivision SubDone (Exclude NodeDone)

--- OLD IMPLEMENTATION FOLLOWS

-- Node Types

kind NodeType = Regular | Universal

-- Node Labels (parametrized by dimension?)

data NodeLabel = Named (Label n)
               | Comp NodeLabel NodeLabel

-- Node: named faces as inputs and an output (face)

-- Consuming some twig

data Eat :: Twig ~> * where
  NoDot :: Eat None  -- do not extend till next sprouting point
  Sub :: Eat (Sprout l)

-- A connected deck of cards

data Deck :: Twig ~> Twig ~> * where
  Air :: Deck t None
  Card :: Eat t -> Deck subt out -> Deck t (Sprout [out]w)

-- A forest: trees in each dimension up to n
--   o when it ends in a corolla then it is a cell (n-dimensional)
--

--data Forest

-- Idea: each tree must have two type parameters
--       o left: set of nodes from dim (n - 1) is our (tree of) lines
--       o right: my set of nodes is the tree I push to dim n + 1

-- HAH! we have a thrist!

-- trees live at the type level

-- have these forms
--      O  |
--   o  |  o
--      o

--         |
-- List of o starts at O

data List :: *1 where
  No :: List
  Ext :: List ~> Twig ~> List
 deriving LeftList(w)

data Twig :: *1 where
  None :: Twig
  Sprout :: List ~> Twig

-- an Opetope is a LeftThrist of Decks

-- Dimension Zero is always:

dim0 = Card NoDot Air

dim1 = Card Sub Air

upto1 = [dim0, dim1]lt