From cb76623a15c668453a369b06698c6896ba3075ee Mon Sep 17 00:00:00 2001 From: Adam Megacz Date: Sun, 15 May 2011 01:28:17 -0700 Subject: [PATCH 1/1] update demo for new more-efficient encoding of functions --- examples/Demo.hs | 3 ++- examples/DemoMain.hs | 2 +- examples/GArrowSkeleton.hs | 9 ++++++++- 3 files changed, 11 insertions(+), 3 deletions(-) diff --git a/examples/Demo.hs b/examples/Demo.hs index 849693f..ff4468c 100644 --- a/examples/Demo.hs +++ b/examples/Demo.hs @@ -11,7 +11,8 @@ foo :: (forall g a . <[ () -> a (forall b . PGArrow g (GArrowTensor g b b) b) -> -} --foo con mer = <[ ~~mer ~~con ~~con ]> -foo const merge = <[ ~~merge ~~const (~~merge ~~const ~~const) ]> +--foo const merge = <[ ~~merge ~~const (~~merge ~~const ~~const) ]> +foo const merge = <[ ~~merge ~~const ~~const ]> --tester2 f = <[ \x -> ~~f x x ]> diff --git a/examples/DemoMain.hs b/examples/DemoMain.hs index d832b6e..9386d00 100644 --- a/examples/DemoMain.hs +++ b/examples/DemoMain.hs @@ -6,4 +6,4 @@ import GHC.HetMet.Private import GArrowTikZ import Demo -main = tikz' $ \const merge -> foo const (pga_comp (pga_second pga_cancelr) merge) +main = tikz' $ \const merge -> foo const merge diff --git a/examples/GArrowSkeleton.hs b/examples/GArrowSkeleton.hs index a64ed31..c07c64a 100644 --- a/examples/GArrowSkeleton.hs +++ b/examples/GArrowSkeleton.hs @@ -168,16 +168,23 @@ optimize x = let x' = optimize' x in if x == x' then x' else optimize x' optimize_pair GAS_uncancelr (GAS_first f) = Just $ GAS_comp f GAS_uncancelr optimize_pair GAS_uncancell (GAS_second f) = Just $ GAS_comp f GAS_uncancell - -- second priority: push GAS_swap leftward... why isn't this working? + -- second priority: push GAS_swap leftward optimize_pair (GAS_second f) GAS_swap = Just $ GAS_comp GAS_swap (GAS_first f) optimize_pair (GAS_first f) GAS_swap = Just $ GAS_comp GAS_swap (GAS_second f) optimize_pair GAS_swap GAS_swap = Just $ GAS_id + optimize_pair GAS_swap GAS_cancell = Just $ GAS_cancelr + optimize_pair GAS_swap GAS_cancelr = Just $ GAS_cancell optimize_pair (GAS_first f) (GAS_first g) = Just $ GAS_first (GAS_comp f g) optimize_pair (GAS_second f) (GAS_second g) = Just $ GAS_second (GAS_comp f g) optimize_pair GAS_assoc GAS_cancell = Just $ GAS_first GAS_cancell optimize_pair GAS_unassoc GAS_cancelr = Just $ GAS_second GAS_cancelr + optimize_pair GAS_assoc (GAS_second GAS_cancell) = Just $ GAS_first GAS_cancelr + + -- FIXME: valid only for central morphisms + --optimize_pair (GAS_second f) (GAS_first g) = Just $ GAS_comp (GAS_first g) (GAS_second f) + optimize_pair (GAS_first g) (GAS_second f) = Just $ GAS_comp (GAS_second f) (GAS_first g) optimize_pair _ _ = Nothing -- 1.7.10.4