packages feed

pointless-haskell (empty) → 0.0.1

raw patch · 12 files changed

+1752/−0 lines, 12 filesdep +GHooddep +arraydep +basesetup-changed

Dependencies added: GHood, array, base, haskell98, pretty, process

Files

+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2008, University of Minho++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * The names of contributors may not be used to endorse or promote+      products derived from this software without specific prior+      written permission. ++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,29 @@+Pointless Haskell++This cabal package can be installed with:++$ cabal install pointless-haskell++For a manual install, execute:++$ runhaskell Setup.lhs configure+$ runhaskell Setup.lhs build+$ runhaskell Setup.lhs install++You can now start playing with the example code that comes with the library, under Language.Pointless.Examples.+The easiest way is to create a new module that imports some library modules++module Test where++import Generics.Pointless.Examples.Examples+import Generics.Pointless.Examples.Observe++and interpret it++$ ghci Test.hs+> factHylo 5+120+> runO $ print $ factHyloO 5+120+...+
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ Test.hs view
@@ -0,0 +1,4 @@+module Test where++import Generics.Pointless.Examples.Examples+import Generics.Pointless.Examples.GHood
+ pointless-haskell.cabal view
@@ -0,0 +1,40 @@+Name:            pointless-haskell+Version:         0.0.1+License:         BSD3+License-file:    LICENSE+Author:          Alcino Cunha <alcino@di.uminho.pt>, Hugo Pacheco <hpacheco@di.uminho.pt>+Maintainer:      Hugo Pacheco <hpacheco@di.uminho.pt>+Synopsis:        Pointless Haskell library+Description:+	Pointless Haskell is library for point-free programming with recursion patterns defined as hylomorphisms, inspired in ideas from the PolyP library.+	Generic recursion patterns can be expressed for recursive types and no support for mutually recursive types or nested data types is provided.+	The library also features the visualization of the intermediate data structure of hylomorphisms with GHood (<http://hackage.haskell.org/cgi-bin/hackage-scripts/package/GHood>).+Homepage:        http://haskell.di.uminho.pt/wiki/Pointless+Haskell++Category: Generics++extra-source-files: README, Test.hs++Build-type: Simple+Cabal-Version:  >=1.2++Flag splitBase+  Description:          Choose the new smaller, split-up base package.++Library+  Hs-Source-Dirs: src+  Build-Depends:        base, GHood, haskell98, process+  if flag(splitBase)+    Build-Depends:      base >= 3, array >= 0.1, pretty >= 1.0+  else+    Build-Depends:      base < 3+  exposed-modules:+        Generics.Pointless.Combinators+        Generics.Pointless.Functors,+        Generics.Pointless.RecursionPatterns,+        Generics.Pointless.Observe.Functors,+        Generics.Pointless.Observe.RecursionPatterns,+        Generics.Pointless.Examples.Examples,+        Generics.Pointless.Examples.Observe++  extensions: TypeFamilies, TypeOperators, ScopedTypeVariables, UndecidableInstances, FlexibleInstances, FlexibleContexts, EmptyDataDecls
+ src/Generics/Pointless/Combinators.hs view
@@ -0,0 +1,161 @@++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.Pointless.Combinators+-- Copyright   :  (c) 2008 University of Minho+-- License     :  BSD3+--+-- Maintainer  :  hpacheco@di.uminho.pt+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Pointless Haskell:+-- point-free programming with recursion patterns as hylomorphisms+-- +-- This module defines many standard combinators used for point-free programming.+--+-----------------------------------------------------------------------------++module Generics.Pointless.Combinators where++-- * Terminal object++-- | The bottom value for any type.+-- It is many times used just for type annotations.+_L :: a+_L = undefined++-- | The final object.+-- The only possible value of type 'One' is '_L'.+data One++instance Show One where+    show _ = "_L"++instance Eq One where+    (==) _ _ = True++-- * Points++-- | Creates a point to the terminal object.+bang :: a -> One+bang = const _L++-- | Converts elements into points.+pnt :: a -> One -> a+pnt x = \_ -> x++-- * Products++infix 6  /\+-- | The infix split combinator.+(/\) :: (a -> b) -> (a -> c) -> a -> (b,c)+(/\) f g x = (f x, g x)++infix 7  ><+-- The infix product combinator.+(><) :: (a -> b) -> (c -> d) -> (a,c) -> (b,d)+f >< g = f . fst /\ g . snd++-- * Sums++-- | Injects a value to the left of a sum.+inl :: a -> Either a b+inl = Left++-- | Injects a value to the right of a sum.+inr :: b -> Either a b+inr = Right++infix 4 \/+-- | The infix either combinator.+(\/) :: (b -> a) -> (c -> a) -> Either b c -> a+(\/) = either++infix 5 -|-+-- | The infix sum combinator.+(-|-) :: (a -> b) -> (c -> d) -> Either a c -> Either b d+f -|- g = inl . f \/ inr . g++infix 5 <>+-- | Alias for the infix sum combinator.+(<>) :: (a -> b) -> (c -> d) -> Either a c -> Either b d+(<>) = (-|-)++-- * Exponentials++-- | The application combinator.+app :: (a -> b, a) -> b+app (f,x) = f x++infix 0 !+-- | The infix combinator for a constant point.+(!) :: a -> b -> a+(!) = const+ +-- * Guards++-- | Guard combinator that operates on Haskell booleans.+grd :: (a -> Bool) -> a -> Either a a+grd p x = if p x then inl x else inr x++-- | Infix guarc combinator that simulates the postfix syntax.+(?) :: (a -> Bool) -> a -> Either a a+(?) = grd++-- * Point-free definitions of uncurried versions of the basic combinators++-- | The uncurried split combinator.+split :: (a -> b, a -> c) -> (a -> (b,c))+split = curry ((app >< app) . ((fst >< id) /\ (snd >< id)))++-- | The uncurried either combinator.+eithr :: (a -> c, b -> c) -> Either a b -> c+eithr = curry ((app \/ app) . (fst >< id -|- snd >< id) . distr)++-- | The uncurried composition combinator.+comp :: (b -> c, a -> b) -> (a -> c)+comp = curry (app . (id >< app) . assocr)++-- * Point-free isomorphic combinators++-- | Swap the elements of a product.+swap :: (a,b) -> (b,a)+swap = snd /\ fst++-- | Swap the elements of a sum.+coswap :: Either a b -> Either b a+coswap = inr \/ inl++-- | Distribute products over the left of sums.+distl :: (Either a b, c) -> Either (a,c) (b,c)+distl = app . ((curry inl \/ curry inr) >< id)++-- | Distribute sums over the left of products.+undistl :: Either (a,c) (b,c) -> (Either a b, c)+undistl = inl >< id \/ inr >< id++-- | Distribute products over the right of sums.+distr :: (c, Either a b) -> Either (c,a) (c,b)+distr = (swap -|- swap) . distl . swap++-- | Distribute sums over the right of products.+undistr :: Either (c,a) (c,b) -> (c, Either a b)+undistr = (id >< inl) \/ (id >< inr)++-- | Associate nested products to the left.+assocl :: (a,(b,c)) -> ((a,b),c)+assocl = id >< fst /\ snd . snd++-- | Associates nested products to the right.+assocr :: ((a,b),c) -> (a,(b,c))+assocr = fst . fst  /\  snd >< id++-- | Associates nested sums to the left.+coassocl :: Either a (Either b c) -> Either (Either a b) c+coassocl = (inl . inl) \/ (inr -|- id)++-- | Associates nested sums to the right.+coassocr :: Either (Either a b) c -> Either a (Either b c)+coassocr = (id -|- inl) \/ (inr . inr)+
+ src/Generics/Pointless/Examples/Examples.hs view
@@ -0,0 +1,728 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.Pointless.Examples.Examples+-- Copyright   :  (c) 2008 University of Minho+-- License     :  BSD3+--+-- Maintainer  :  hpacheco@di.uminho.pt+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Pointless Haskell:+-- point-free programming with recursion patterns as hylomorphisms+-- +-- This module provides examples, examples and more examples.+--+-----------------------------------------------------------------------------++module Generics.Pointless.Examples.Examples where++import Generics.Pointless.Combinators+import Generics.Pointless.Functors+import Generics.Pointless.RecursionPatterns+import Prelude hiding (Functor(..),filter,concat,tail,length)+import Data.List hiding (filter,concat,tail,length,partition)++-- * Integers++-- | The number 1.+one = suck . zero++-- ** Addition++-- | Pre-defined algebraic addition.+add :: (Int,Int) -> Int+add = uncurry (+)++-- | Definition of algebraic addition as an anamorphism in the point-wise style.+addAnaPW :: (Int,Int) -> Int+addAnaPW = ana (_L::Int) h +   where h (0,0) = Left _L +         h (n,0) = Right (n-1,0) +         h (0,n) = Right (0,n-1) +         h (n,m) = Right (n,m-1)++-- | Defition of algebraic addition as an anamorphism.+addAna :: (Int,Int) -> Int+addAna = ana (_L::Int) f+   where f = (bang -|- (id >< zero \/ (zero >< id \/ succ >< id))) . aux . (out >< out)+         aux = coassocr . (distl -|- distl) . distr++-- | The fixpoint of the functor that is either a constant or defined recursively.+type From a = K a :+!: I++-- | Definition of algebraic addition as an hylomorphism.+addHylo :: (Int,Int) -> Int+addHylo = hylo (_L::From Int) f g+   where f = id \/ succ+         g = (snd -|- id) . distl . (out >< id)++-- | Definition of algebraic addition as an accumulation.+addAccum :: (Int,Int) -> Int+addAccum = accum (_L::Int) t f+   where t = (fst -|- id >< succ) . distl+         f = (snd \/ fst) . distl++-- | Definition of algebraic addition as an apomorphism.+addApo :: (Int,Int) -> Int+addApo = apo (_L::Int) h+   where h = (id -|- coswap) . coassocr . (fst -|- inn >< id) . distr . (out >< out)+         +-- ** Product++-- | Pre-defined algebraic product.+prod :: (Int,Int) -> Int+prod = uncurry (*)++-- | Definition of algebraic product as an hylomorphism+prodHylo :: (Int,Int) -> Int+prodHylo = hylo (_L::[Int]) f g+   where f = zero \/ add+         g = (snd -|- fst /\ id) . distr . (id >< out)++-- ** 'Greater than' comparison++-- | Pre-defined 'greater than' comparison.+gt :: Ord a => (a,a) -> Bool+gt = uncurry (>)++-- | Definition of 'greater than' as an hylomorphism.+gtHylo :: (Int,Int) -> Bool+gtHylo = hylo (_L :: From Bool) f g+    where g = ((((False!) \/ (True!)) \/ (False!)) -|- id) . coassocl . (distl -|- distl) . distr . (out >< out)+	  f = id \/ id++-- ** Factorial++-- | Native recursive definition of the factorial function.+fact :: Int -> Int+fact 0 = 1+fact n = n * fact (n-1)++-- | Recursive definition of the factorial function in the point-free style.+factPF :: Int -> Int+factPF = ((1!) \/ prod) .+         (id -|- id >< factPF) . +         (id -|- id /\ pred) . (iszero?)+   where iszero = (==0)++-- | Recursive definition of the factorial function in the point-free style with structural recursion.+factPF' :: Int -> Int+factPF' = (one \/ prod) . (id -|- id >< factPF') . (id -|- succ /\ id) . out++-- | Definition of the factorial function as an hylomorphism.+factHylo :: Int -> Int+factHylo = hylo (_L :: [Int]) f g+   where g = (id -|- succ /\ id) . out+         f = one \/ prod++-- | Definition of the factorial function as a paramorphism.+factPara :: Int -> Int+factPara = para (_L::Int) f+   where f = one \/ (prod . (id >< succ))++-- | Definition of the factorial function as a zygomorphism.+factZygo :: Int -> Int+factZygo = zygo (_L::Int) inn f+   where f = one \/ (prod . (id >< succ))++-- ** Fibonnaci++-- | Native recursive definition of the fibonacci function.+fib :: Int -> Int+fib 0 = 0+fib 1 = 1+fib n = fib (n-1) + fib (n-2)++-- | Recursive definition of the fibonacci function in the point-free style.+fibPF :: Int -> Int+fibPF = (zero \/ (one \/ add)) . (bang -|- (bang -|- fibPF >< fibPF)) . (id -|- aux) . ((==0)?)+   where aux = (id -|- pred /\ pred . pred) . ((==1)?)++-- | Recursive definition of the fibonacci function in the point-free style with structural recursion.+fibPF' :: Int -> Int+fibPF' = (zero \/ (one \/ add)) . (id -|- (id -|- fibPF' >< fibPF')) . (id -|- aux) . out+   where aux = (id -|- succ /\ id) . out++-- | The fixpoint of the functor for a binary shape tree.+type BSTree = K One :+!: (K One :+!: I :*!: I)++-- | Definition of the fibonacci function as an hylomorphism.+fibHylo :: Int -> Int+fibHylo = hylo (_L :: BSTree) f g+   where f = zero \/ (one \/ add)+         g = (id -|- ((id -|- succ /\ id) . out)) . out+         ++-- | Definition of the fibonacci function as an histomorphism.+fibHisto :: Int -> Int+fibHisto = histo (_L::Int) f+   where f = (zero \/ (one . snd \/ add . (id >< outl)) . distr . out)++-- | Definition of the fibonacci function as a dynamorphism.+fibDyna :: Int -> Int+fibDyna = dyna (_L::Int) f g+   where f = (zero \/ (one . snd \/ add . (id >< outl)) . distr . out)+         g = out++-- ** Binary Partitioning++-- | Native recursive definition for the binary partitions of a number.+--+-- The number of binary partitions for a number n is the number of unique ways to partition+-- this number (ignoring the order) into powers of 2.+-- | Definition of the binary partitioning of a number as an hylomorphism.+bp :: Int -> Int+bp 0 = 1+bp n = if (odd n) then bp (n-1) else bp (n-1) + bp (div n 2)++-- | The fixpoint of the functor representing trees with maximal branching factor of two.+type BTree = K One :+!: (I :+!: (I :*!: I))++-- | Definition of the binary partitioning of a number as an hylomorphism.+bpHylo :: Int -> Int+bpHylo = hylo (_L :: BTree) g h+   where g = one \/ (id \/ add)+         h = (id -|- h') . out+         h' = (id -|- id /\ (`div` 2) . succ) . (even?)++-- | Definition of the binary partitioning of a number as a dynamorphism.+bpDyna :: Int -> Int+bpDyna = dyna (_L :: [Int]) (g . o) h+   where g = one \/ (id \/ add)+         o = id -|- oj+         oj = (o1 -|- o2) . ((odd . fst)?)+         o1 = outl . snd+         o2 = outl . snd /\ (outl . oi)+         oi = uncurry pi . ((pred . (`div` 2)) >< id)+         h = (id -|- succ /\ id) . out+         pi 0 x = x +         pi k x = case (outr x) of+            Right (_,y) -> pi (pred k) y++-- ** Average++-- | Recursive definition of the average of a set of integers.+average :: [Int] -> Int+average = uncurry div . (sum /\ length)++-- | Definition of the average of a set of integers as a catamorphism.+averageCata :: [Int] -> Int+averageCata = uncurry div . cata (_L::[Int]) f+   where f = (zero \/ add . (id >< fst)) /\ (zero \/ succ . snd . snd)++-- * Lists++-- ** Singleton list.++-- | Pre-defined wrapping of an element into a list.+wrap :: a -> [a]+wrap x = x:[]++-- | Definition of wrapping in the point-free style.+wrapPF :: a -> [a]+wrapPF = cons . (id /\ nil . bang)++-- ** Tail++-- | Definition of the tail of a list as a total function.+tail :: [a] -> [a]+tail [] = []+tail (x:xs) = xs++-- | Definition of the tail of a list in the point-free style.+tailPF :: [a] -> [a]+tailPF = (([]!) \/ snd) . out++-- | Definition of the tail of a list as an anamorphism.+tailCata :: [a] -> [a]+tailCata = fst . (cata (_L::[a]) (f /\ inn . (id -|- id >< snd)))+   where f = ([]!) \/ snd . snd++-- | Definition of the tail of a list as a paramorphism.+tailPara :: [a] -> [a]+tailPara = para (_L::[a]) f+   where f = ([]!) \/ snd . snd++-- ** Length++-- | Native recursion definition of list length.+length :: [a] -> Int+length [] = 0+length (x:xs) = succ (length xs)++-- | Recursive definition of list length in the point-free style.+lengthPF :: [a] -> Int+lengthPF = (zero . bang \/ succ . lengthPF . tail) . (null?)++-- | Recursive definition of list length in the point-free style with structural recursion.+lengthPF' :: [a] -> Int+lengthPF' = inn . (id -|- (lengthPF' . snd)) . out++-- | Definition of list length as an hylomorphism.+lengthHylo :: [a] -> Int+lengthHylo = hylo (_L::Int) f g+   where f = inn+         g = (id -|- snd) . out++-- | Definition of list length as an anamorphism.+lengthAna :: [a] -> Int+lengthAna = ana _L f+   where f = (id -|- snd) . out++-- | Definition of list length as a catamorphism.+lengthCata :: [a] -> Int+lengthCata = cata (_L) f+    where f = zero \/ succ . snd++-- ** Filtering++-- | Native recursive definition of list filtering.+filter :: (a -> Bool) -> [a] -> [a]+filter p [] = []+filter p (x:xs) = if p x then x : filter p xs else filter p xs++-- | Definition of list filtering as an catamorphism.+filterCata :: (a -> Bool) -> [a] -> [a]+filterCata p = cata (_L::[a]) f+   where f = (nil \/ (cons \/ snd)) . (id -|- ((p . fst)?))++-- ** Generation++-- | Generation of infinite lists as an anamorphism.+repeatAna :: a -> [a]+repeatAna = ana (_L::[a]) (inr . (id /\ id))++-- | Finite replication of an element as an anamorphism.+replicateAna :: (Int,a) -> [a]+replicateAna = ana (_L::[a]) h+   where h = (bang -|- snd /\ id) . distl . (out >< id)++-- | Generation of a downwards list as an anamorphism.+downtoAna :: Int -> [Int]+downtoAna = ana (_L) f+   where f = (bang -|- (id /\ pred)) . ((==0) ?)++-- | Ordered list insertion as an apomorphism.+insertApo :: Ord a => (a,[a]) -> [a]+insertApo = apo (_L::[a]) f+   where f = inr. undistr . (inr \/ (inr \/ inl)) . ((id >< nil) -|- ((id >< cons) . assocr -|- assocr . (swap >< id)) . distl . ((le?) >< id) . assocl) . distr . (id >< out)+         le = uncurry (<=)++-- | Ordered list insertion as a paramorphism.+insertPara :: Ord a => (a,[a]) -> [a]+insertPara (x,l) = para (_L::[a]) f l+   where f = wrap . (x!) \/ ((x:) . cons . (id >< snd) \/ cons . (id >< fst)) . (((x <=) . fst)?)++-- | Append an element to the end of a list as an hylomorphism.+snoc :: (a,[a]) -> [a]+snoc = hylo (_L::NeList a a) f g+   where g = (fst -|- assocr . (swap >< id) . assocl) . distr . (id >< out)+         f = wrap \/ cons++-- | Append an element to the end of a list as an apomorphism.+snocApo :: (a,[a]) -> [a]+snocApo = apo (_L::[a]) h+   where h = inr . undistr . coswap . (id >< nil  -|-  assocr . (swap >< id) . assocl) . distr . (id >< out)++-- ** Extraction++-- | Creates a bubble from a list. Used in the bubble sort algorithm.+bubble :: (Ord a) => [a] -> Either One (a,[a])+bubble = cata (_L::[a]) f+   where f = id -|- ((id >< ([]!)) \/ ((id >< cons) . assocr . (id \/ (swap >< id)) . ((uncurry (<) . fst) ?) . assocl)) . distr++-- | Extraction of a number of elements from a list as an anamorphism.+takeAna :: (Int,[a]) -> [a]+takeAna = ana (_L::[a]) h+   where h = (bang -|- assocr . (swap >< id) . assocl) . aux . (out >< out)+         aux = coassocl . (distl -|- distl) . distr++-- ** Partition++-- | Native recursive definition for partitioning a list at a specified element.+partition :: Ord a => (a,[a]) -> ([a],[a])+partition (a,xs) = foldr (select a) ([],[]) xs+   where select :: Ord a => a -> a -> ([a], [a]) -> ([a], [a])+         select a x (ts,fs) = if a > x then (x:ts,fs) else (ts, x:fs)++-- | Definition for partitioning a list at a specified element as an hylomorphism.+partitionHylo :: (Ord a) => (a,[a]) -> ([a],[a])  +partitionHylo = hylo (_L::[(a,a)]) f g+   where g = (snd -|- ((id >< fst) /\ (id >< snd))) . distr . (id >< out)+         f = (nil /\ nil) \/ (((cons >< id) . assocl . (snd >< id) \/ (id >< cons) . ((fst . snd) /\ (id >< snd)) . (snd >< id)) . ((gt . fst)?))++-- **  Transformations++-- | Incremental summation as a catamorphism.+isum :: [Int] -> [Int]+isum = cata (_L::[Int]) f+   where f = nil \/ isumOp . swap . (id >< cons . (zero . bang /\ id))+         isumOp (l,x) = map (x+) l++-- | Incrementation the elements of a list by a specified value a catamorphism.+fisum :: [Int] -> Int -> [Int]+fisum = cata (_L::[Int]) f+    where f = pnt (nil . bang) \/ comp . swap . (curry add >< (cons .) . split . (pnt id . bang /\ id))++-- | Definition of list mapping as a catamorphism.+mapCata :: [a] -> (a -> b) -> [b]+mapCata = cata (_L::[a]) f+   where f = (([]!)!) \/ (curry (cons . (app . swap >< app) . ((fst >< id) /\ (snd >< id))))++-- | Definition of list reversion as a catamorphism.+reverseAna :: [a] -> [a]+reverseAna = cata (_L::[a]) f +    where f = nil \/ (cat . swap . (wrap >< id))++-- | Definition of the quicksort algorithm as an hylomorphism.+qsort :: (Ord a) => [a] -> [a]+qsort = hylo (_L::Tree a) f g+   where g = (id -|- (fst /\ partition)) . out+         f = nil \/ (cat . (id >< cons) . assocr . (swap >< id) . assocl)++-- | Definition of the bubble sort algorithm as an anamorphism.+bsort :: (Ord a) => [a] -> [a]+bsort = ana (_L::[a]) bubble+-- | Definition of the insertion sort algorithm as a catamorphism.+isort :: (Ord a) => [a] -> [a]+isort = cata (_L::[a]) (nil \/ insertApo)++-- Auxiliary split function for the merge sort algorithm.+msplit :: [a] -> ([a],[a])+msplit = cata (_L::[a]) f+    where f = (nil /\ nil) \/ (swap . (cons >< id) . assocl)++-- Definition of the merge sort algorithm as an hylomorphism.+msort :: (Ord a) => [a] -> [a]+msort = hylo (_L::(K One :+!: K a) :+!: (I :*!: I)) f g+    where g = coassocl . (id -|- (fst -|- msplit . cons) . ((null . snd)?)) . out +	  f = (([]!) \/ wrap) \/ merge++-- | Definition of the heap sort algorithm as an hylomorphism.+hsort :: (Ord a) => [a] -> [a]+hsort = hylo f g h+    where f = _L ::(K One :+!: K a) :+!: (K a :*!: (I :*!: I)) +	  h = coassocl . (id -|- (fst -|- hsplit . cons) . ((null . snd)?)) . out+	  g = (([]!) \/ wrap) \/ cons . (id >< merge)++-- Auxiliary split function for the heap sort algorithm.+hsplit :: (Ord a) => [a] -> (a,([a],[a]))+hsplit [x] = (x,([],[]))+hsplit (h:t) | h < m     = (h,(m:l,r))+	     | otherwise = (m,(h:r,l))+	     where (m,(l,r)) = hsplit t++-- | Malcolm downwards accumulations on lists.+malcolm :: ((b, a) -> a) -> a -> [b] -> [a]+malcolm o e = map (cata (_L::[b]) ((e!) \/ o)) . malcolmAna' cons . (id /\ nil . bang)++-- | Malcom downwards accumulations on lists as an anamorphism.+malcolmAna :: ((b, a) -> a) -> a -> [b] -> [a]+malcolmAna o e = malcolmAna' o . (id /\ (e!))++-- | Uncurried version of Malcom downwards accumulations on lists as an anamorphism.+malcolmAna' :: ((b, a) -> a) -> ([b], a) -> [a]+malcolmAna' o = ana (_L::[a]) g+   where g = (fst -|- (snd /\ (id >< o) . assocr . (swap >< id))) . distl . (out >< id)++-- ** Zipping++-- | Definition of the zip for lists of pairs as an anamorphism.+zipAna :: ([a],[b]) -> [(a,b)]+zipAna = ana (_L::[(a,b)]) f+   where f = (bang -|- ((fst >< fst) /\ (snd >< snd))) . aux . (out >< out)+         aux = coassocl . (distl -|- distl) . distr++-- ** Subsequencing++-- | Definition of the subsequences of a list as a catamorphism.+subsequences :: Eq a => [a] -> [[a]]+subsequences = cata (_L::[a]) f+   where f = cons . (nil /\ nil) \/ (uncurry union) . (snd /\ subsOp . swap . (wrap >< id))+         subsOp (r,l) = map (l++) r++-- ** Concatenation++-- | Pre-defined list concatenation.+cat :: ([a],[a]) -> [a]+cat = uncurry (++)++-- | List concatenation as a catamorphism.+catCata :: [a] -> [a] -> [a]+catCata = cata (_L::[a]) f+   where f = (id!) \/ (comp . (curry cons >< id))++-- | The fixpoint of the list functor with a specific terminal element.+type NeList a b = K a :+!: (K b :*!: I)++-- | List concatenation as an hylomorphism.+catHylo :: ([a],[a]) -> [a]+catHylo = hylo (_L::NeList [a] a) f g+   where g = (snd -|- assocr) . distl . (out >< id)+         f = id \/ cons++-- | Native recursive definition of lists-of-lists concatenation.+concat :: [[a]] -> [a]+concat [] = []+concat (l:ls) = l ++ concat ls++-- | Definition of lists-of-lists concatenation as an anamorphism.+concatCata :: [[a]] -> [a]+concatCata = cata (_L::[[a]]) g+   where g = ([]!) \/ cat++-- | Sorted concatenation of two lists as an hylomorphism.+merge :: (Ord a) => ([a],[a]) -> [a]+merge = hylo (_L::NeList [a] a) f g+   where g = ((id \/ id) -|- ((id \/ id) . (assocr -|- (assocr . (swap >< id) . assocl)) . (id >< cons -|- cons >< id) . (((uncurry (<)) . (fst >< fst))?) )) . coassocl . (snd -|- (((cons . fst) -|- id) . distr . (id >< out))) . distl . (out >< id)+         f = id \/ cons++-- ** Summation++-- | Definition of inter addition as a catamorphism.+sumCata :: [Int] -> Int+sumCata = cata (_L::[Int]) f+   where f = (0!) \/ add++-- ** Multiplication++-- | Native recursive definition of integer multiplication.+mult :: [Int] -> Int+mult [] = 1+mult (x:xs) = x * mult xs++-- | Definition of integer multiplication as a catamorphism.+multCata :: [Int] -> Int+multCata = cata (_L) f+	    where f = (1!) \/ prod++-- ** Predicates++-- Test if a list is sorted as a paramorphism.+sorted :: (Ord a) => [a] -> Bool+sorted = para (_L::[a]) f+    where f = true \/ (uncurry (&&)) . ((true . bang \/ (uncurry (<=)) . (id >< head)) . ((null . snd)?) >< id) . assocl . (id >< swap)++-- ** Edit distance++-- | Native recursive definition of the edit distance algorithm.+--+-- Edit distance is a classical dynamic programming algorithm that calculates+-- a measure of “distance” or “difference” between lists with comparable elements.+editdist :: Eq a => ([a],[a]) -> Int+editdist ([],bs) = length bs+editdist (as,[]) = length as+editdist (a:as,b:bs) = minimum [m1,m2,m3]+   where m1 = editdist (as,b:bs) + 1+         m2 = editdist (a:as,bs) + 1+         m3 = editdist (as,bs) + (if a==b then 0 else 1)++-- | The fixpoint of the functor that represents a virtual matrix used to accumulate and look up values for the edit distance algorithm.+--+-- Since matrixes are not inductive types, a walk-through of a matrix is used, consisting in a list of values from the matrix ordered predictability.+--+-- For a more detailed explanation, please refer to <http://math.ut.ee/~eugene/kabanov-vene-mpc-06.pdf>.+type EditDist a = K [a] :+!: ((K a :*!: K a) :*!: I :*!: I :*!: I)+type EditDistL a = (K [a] :*!: K [a]) :*!: (K One :+!: I)++-- | The edit distance algorithm as an hylomorphism.+editdistHylo :: Eq a => ([a],[a]) -> Int+editdistHylo (x::([a],[a])) = hylo (_L::EditDist a) g h x+   where g :: Eq a => F (EditDist a) Int -> Int+         g = length \/ g'+         g' ((a,b),(x1,(x2,x3))) = min m1 (min m2 m3)+            where m1 = succ x1+                  m2 = succ x2+                  m3 = add (x3,if (a==b) then 0 else 1)+         h ([],bs) = Left bs+         h (as,[]) = Left as+         h (a:as,b:bs) = Right ((a,b),((as,b:bs),((a:as,bs),(as,bs))))++-- | The edit distance algorithm as a dynamorphism.+editDistDyna :: Eq a => ([a],[a]) -> Int+editDistDyna (l1::[a],l2) = dyna (_L :: EditDistL a) (g . o (length l1)) (h l1) (l1,l2)+   where g :: Eq a => F (EditDist a) Int -> Int+         g = length \/ g'+         g' ((a,b),(x1,(x2,x3))) = min m1 (min m2 m3)+            where m1 = succ x1+                  m2 = succ x2+                  m3 = add (x3,if (a==b) then 0 else 1)+         o :: Int -> F (EditDistL a) (Histo (EditDistL a) Int) -> F (EditDist a) Int+         o n ((as,bs),Left _) = Left []+         o n (([],bs),Right x) = Left bs+         o n ((as,[]),Right x) = Left as+         o n ((a:as,b:bs),Right x) = Right ((a,b),(j x,(j (pi n x),j (pi (succ n) x))))+         h :: [a] -> ([a],[a]) -> F (EditDistL a) ([a],[a])+         h cs ([],[]) = (([],[]),Left _L)+         h cs ([],b:bs) = (([],b:bs),Right (cs,bs))+         h cs (a:as,bs) = ((a:as,bs),Right (as,bs))+         pi :: Int -> Histo (EditDistL a) Int -> Histo (EditDistL a) Int+         pi 0 x = x+         pi k x = case (outr x) of+            (_,Right y) -> pi (pred k) y+         j = outl++-- * Streams++-- | The fixpoint of the functor of streams.+type Stream a = K a :*!: I++-- | Stream head.+headS :: Stream a -> a+headS = fst . out++-- | Stream tail.+tailS :: Stream a -> Stream a+tailS = snd . out++-- | Definition of a stream sequence generator as an anamorphism. +generate :: Int -> Stream Int+generate = ana (_L::Stream Int) (id /\ succ)++-- | Identity o streams as an anamorphism.+idStream :: Stream a -> Stream a+idStream = ana (_L::Stream a) out++-- | Mapping over streams as an anamorphism.+mapStream :: (a -> b) -> Stream a -> Stream b+mapStream f = ana (_L::Stream b) g +    where g = (f >< id) . out++-- | Malcolm downwards accumulations on streams.+malcolmS :: ((b,a) -> a) -> a -> Stream b -> Stream a+malcolmS o e = mapStream (cata (_L::[b]) ((e!) \/ o)) . malcolmSAna' cons . (id /\ nil . bang)++-- | Malcom downwards accumulations on streams as an anamorphism.+malcolmSAna :: ((b,a) -> a) -> a -> Stream b -> Stream a+malcolmSAna o e = malcolmSAna' o . (id /\ (e!))++-- | Uncurried version of Malcom downwards accumulations on streams as an anamorphism.+malcolmSAna' :: ((b,a) -> a) -> (Stream b, a) -> Stream a+malcolmSAna' o = ana (_L::Stream a) g+    where g = snd /\ swap . (o >< id) . assocl . (id >< swap) . assocr . (out >< id)++-- | Promotes streams elements to streams of singleton elements.+inits :: Stream a -> Stream [a]+inits = malcolmSAna' cons . (id /\ nil . bang)++-- | Definition of parwise exchange on streams as a futumorphism.+exchFutu :: Stream a -> Stream a+exchFutu = futu (_L::Stream a) (f /\ (g . (h /\ i)))+   where f = headS . tailS+         g = innr+         h = headS+         i = innl . tailS . tailS++-- * Binary Tree++-- | Datatype declaration of a binary tree.+data Tree a = Empty | Node a (Tree a) (Tree a) deriving Show++-- | The functor of a binary tree.+type instance PF (Tree a) = Const One :+: (Const a :*: (Id :*: Id))++instance Mu (Tree a) where+   inn (Left _) = Empty+   inn (Right (a,(b,c))) = Node a b c+   out Empty = Left _L+   out (Node a b c) = Right (a,(b,c))++-- | Counting the number of leaves in a binary tree as a catamorphism.+nleaves :: Tree a -> Int+nleaves = cata (_L::Tree a) f+    where f = (1!) \/ (add . snd)++-- | Counting the number of nodes in a binary tree as a catamorphism.+nnodes :: Tree a -> Int+nnodes = cata (_L::Tree a) f+    where f = (0!) \/ (succ . add . snd)++-- | Generation of a binary tree with a specified height as an anamorphism.+genTree :: Int -> Tree Int+genTree = ana (_L::Tree Int) f+    where f = (bang -|- (id /\ (pred /\ pred))) . ((==0)?)++-- | The preorder traversal on binary trees as a catamorphism.+preTree :: Tree a -> [a]+preTree = cata (_L::Tree a) f+    where f = ([]!) \/ (cons . (id >< cat))++-- | The postorder traversal on binary trees as a catamorphism.+postTree :: Tree a -> [a]+postTree = cata (_L::Tree a) f+    where f = ([]!) \/ (cat . swap . (wrap >< cat))++-- * Leaf Trees++-- | Datatype declaration of a leaf tree.+data LTree a = Leaf a | Branch (LTree a) (LTree a)++-- | The functor of a leaf tree.+type instance PF (LTree a) = Const a :+: (Id :*: Id)++instance Mu (LTree a) where+   inn (Left x) = Leaf x+   inn (Right (x,y)) = Branch x y+   out (Leaf x) = Left x+   out (Branch x y) = Right (x,y)++-- | Extract the leaves of a leaf tree as a catamorphism.+leaves :: LTree a -> [a]+leaves = cata (_L::LTree a) f+    where f = wrap \/ cat++-- | Generation of a leaft tree of a specified height as an anamorphism.+genLTree :: Int -> LTree Int+genLTree = ana (_L::LTree Int) f+    where f = ((0!) -|- (id /\ id)) . out++-- | Calculate the height of a leaf tree as a catamorphism.+height :: LTree a -> Int+height = cata (_L::LTree a) f+    where f = (0!) \/ (succ . (uncurry max))++-- * Rose Trees++-- | Datatype declaration of a rose tree.+data Rose a = Forest a [Rose a] deriving Show++-- | The functor of a rose tree.+type instance PF (Rose a) = Const a :*: ([] :@: Id)++instance Mu (Rose a) where+   inn (a,l) = Forest a l+   out (Forest a l) = (a,l)++--	 The preorder traversal on rose trees as a catamorphism.+preRose :: Rose a -> [a]+preRose = cata (_L::Rose a) f+   where f = (cons . (id >< concat))++-- | The postorder traversal on rose trees as a catamorphism.+postRose :: Rose a -> [a]+postRose = cata (_L::Rose a) f+   where f = cat . swap . (wrap >< cata (_L::[[a]]) (nil \/ cat))++-- | Generation of a rose tree of a specified height as an anamorphism.+genRose :: Int -> Rose Int+genRose = ana (_L::Rose Int) f+   where f = ((id /\ ([]!)) \/ (id /\ downtoAna . pred)) . ((==0)?)++++++++++++++++++
+ src/Generics/Pointless/Examples/Observe.hs view
@@ -0,0 +1,95 @@++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.Pointless.Examples.Observe+-- Copyright   :  (c) 2008 University of Minho+-- License     :  BSD3+--+-- Maintainer  :  hpacheco@di.uminho.pt+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Pointless Haskell:+-- point-free programming with recursion patterns as hylomorphisms+-- +-- This module provides the same examples, but with support for GHood observations.+--+-----------------------------------------------------------------------------++module Generics.Pointless.Examples.Observe where++import Generics.Pointless.Combinators+import Generics.Pointless.Functors+import Generics.Pointless.RecursionPatterns+import Generics.Pointless.Observe.RecursionPatterns+import Generics.Pointless.Observe.Functors+import Generics.Pointless.Examples.Examples+import Debug.Observe+import Data.Typeable++-- | Definition of the observable length function as an hylomorphism.+lengthHyloO :: Observable a => [a] -> Int+lengthHyloO = hyloO (_L::Int) f g+   where f = inn+         g = (id -|- snd) . out++-- | Definition of the observable length function as an anamorphism.+lengthAnaO :: Observable a => [a] -> Int+lengthAnaO = anaO (_L::Int) f+   where f = (id -|- snd) . out++-- | Definition of the observable length function as a catamorphism.+lengthCataO :: (Typeable a, Observable a) => [a] -> Int+lengthCataO = cataO (_L :: [a]) g+   where g = inn . (id -|- snd)++-- | Definition of the observable factorial function as an hylomorphism.+factHyloO :: Int -> Int+factHyloO = hyloO (_L::[Int]) f g+    where g = (id -|- succ /\ id) . out+          f = one \/ prod++-- | Definition of the observable factorial function as a paramorphism.+factParaO :: Int -> Int+factParaO = paraO (_L::Int) f+    where f = one \/ prod . (id >< succ)++-- | Definition of the observable factorial function as a zygomorphism.+factZygoO :: Int -> Int+factZygoO = zygoO (_L::Int) inn f+   where f = one \/ (prod . (id >< succ))++-- | Definition of the observable fibonacci function as an hylomorphism.+fibHyloO :: Int -> Int+fibHyloO = hyloO (_L::LTree One) f g+    where g = (bang -|- pred /\ pred . pred) . ((<=1)?)+	  f = one \/ add+	+-- | Definition of the observable fibonacci function as an histomorphism.+fibHistoO :: Int -> Int+fibHistoO = histoO (_L::Int) f+   where f = (zero \/ (one . snd \/ add . (id >< outl)) . distr . out)++-- | Definition of the observable fibonacci function as a dynamorphism.+fibDynaO :: Int -> Int+fibDynaO = dynaO (_L::Int) f g+   where f = (zero \/ (one . snd \/ add . (id >< outl)) . distr . out)+         g = out++-- | Definition of the observable quicksort function as an hylomorphism.+qsortHyloO :: (Typeable a, Observable a, Ord a) => [a] -> [a]+qsortHyloO = hyloO (_L::Tree a) f g+    where g = (id -|- fst /\ partition) . out+	  f = nil \/ cat . (id >< cons) . assocr . (swap >< id) . assocl++-- | Definition of the observable tail function as a paramorphism.+tailParaO :: (Typeable a, Observable a) => [a] -> [a]+tailParaO = paraO (_L::[a]) (nil \/ snd . snd)++-- | Definition of the observable add function as an accumulation.+addAccumO :: (Int,Int) -> Int+addAccumO = accumO (_L::Int) t f+    where t = (fst -|- id >< succ) . distl+	  f = (snd \/ fst) . distl++
+ src/Generics/Pointless/Functors.hs view
@@ -0,0 +1,251 @@++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.Pointless.Functors+-- Copyright   :  (c) 2008 University of Minho+-- License     :  BSD3+--+-- Maintainer  :  hpacheco@di.uminho.pt+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Pointless Haskell:+-- point-free programming with recursion patterns as hylomorphisms+-- +-- This module defines data types as fixed points of functor.+-- Pointless Haskell works on a view of data types as fixed points of functors, in the same style as the PolyP (<http://www.cse.chalmers.se/~patrikj/poly/polyp/>) library.+-- Instead of using an explicit fixpoint operator, a type function is used to relate the data types with their equivalent functor representations.+--+-----------------------------------------------------------------------------++module Generics.Pointless.Functors where++import Generics.Pointless.Combinators+import Prelude hiding (Functor(..))++-- * Functors++-- ** Definition and operations over functors++-- | Identity functor.+newtype Id x = Id {unId :: x}++-- | Constant functor.+newtype Const t x = Const {unConst :: t}++-- | Sum of functors.+infixr 5 :+:+data (g :+: h) x = Inl (g x) | Inr (h x)++-- | Product of functors.+infixr 6 :*:+data (g :*: h) x = g x :*: h x++-- | Composition of functors.+infixr 9 :@:+newtype (g :@: h) x = Comp {unComp :: g (h x)}++-- | Explicit fixpoint operator.+newtype Fix f = Fix { -- | The unfolding of the fixpoint of a functor is a the functor applied to its fixpoint.+	                   --+	                   -- 'unFix' is specialized with the application of 'Rep' in order to subsume functor application+                         unFix :: Rep f (Fix f)+                    }++instance Show (Rep f (Fix f)) => Show (Fix f) where+   show (Fix f) = "(Fix " ++ show f ++ ")"++-- | Family of patterns functors of data types.+--+-- The type function is not necessarily injective, this is, different data types can have the same base functor.+type family PF a :: * -> *+-- ^ Semantically, we can say that @a = 'Fix' f@.++type instance PF (Fix f) = f+-- ^ The pattern functor of the fixpoint of a functor is the functor itself.++-- | Family of functor representations.+--+-- The 'Rep' family implements the implicit coercion between the application of a functor and the structurally equivalent sum of products.+type family Rep (f :: * -> *) x :: *+-- ^ Functors applied to types can be represented as sums of products.++type instance Rep Id x = x+-- ^ The identity functor applied to some type is the type itself.++type instance Rep (Const t) x = t+-- ^ The constant functor applied to some type is the type parameterized by the functor.++type instance Rep (g :+: h) x = Rep g x `Either` Rep h x+-- ^ The application of a sum of functors to some type is the sum of applying the functors to the argument type.++type instance Rep (g :*: h) x = (Rep g x,Rep h x)+-- ^ The application of a product of functors to some type is the product of applying the functors to the argument type.++type instance Rep (g :@: h) x = Rep g (Rep h x)+-- ^ The application of a composition of functors to some type is the nested application of the functors to the argument type.+--+-- This particular instance requires that nexted type function application is enabled as a type system extension.++type instance Rep [] x = [x]+-- ^ The application of the list functor to some type returns a list of the argument type.++-- | Polytypic 'Prelude.Functor' class for functor representations+class Functor (f :: * -> *) where+   fmap :: Fix f                          -- ^ For desambiguation purposes, the type of the functor must be passed as an explicit paramaeter to 'fmap'+        -> (x -> y) -> Rep f x -> Rep f y -- ^ The mapping over representations++instance Functor Id where+   fmap _ f = f+-- ^ The identity functor applies the mapping function the argument type++instance Functor (Const t) where+   fmap _ f = id+-- ^ The constant functor preserves the argument type++instance (Functor g,Functor h) => Functor (g :+: h) where+   fmap _ f (Left x) = Left (fmap (_L :: Fix g) f x)+   fmap _ f (Right x) = Right (fmap (_L :: Fix h) f x)+-- ^ The sum functor recursively applies the mapping function to each alternative++instance (Functor g,Functor h) => Functor (g :*: h) where+   fmap _ f (x,y) = (fmap (_L :: Fix g) f x,fmap (_L :: Fix h) f y)+-- ^ The product functor recursively applies the mapping function to both sides++instance (Functor g,Functor h) => Functor (g :@: h) where+   fmap _ f x = fmap (_L :: Fix g) (fmap (_L :: Fix h) f) x+-- ^ The composition functor applies in the nesting of the mapping function to the nested functor applications++instance Functor [] where+   fmap _ f l = map f l+-- ^ The list functor maps the specific 'map' function over lists of types++-- | Short alias to express the structurally equivalent sum of products for some data type+type F a x = Rep (PF a) x++-- | Polytypic map function+pmap :: Functor (PF a) => a                          -- ^ A value of a data type that is the fixed point of the desired functor+                       -> (x -> y) -> F a x -> F a y -- ^ The mapping over the equivalent sum of products+pmap (_::a) f = fmap (_L :: Fix (PF a)) f++-- | The 'Mu' class provides the value-level translation between data types and their sum of products representations+class Mu a where+    -- | Packs a sum of products into one equivalent data type+    inn :: F a a -> a+    -- | unpacks a data type into the equivalent sum of products+    out :: a -> F a a++instance Mu (Fix f) where+   inn = Fix+   out = unFix+-- ^ Expanding/contracting the fixed point of a functor is the same as consuming/applying it's single type constructor++-- ** Fixpoint combinators++-- | In order to simplify type-level composition of functors, we can create fixpoint combinators that implicitely assume fixpoint application.++data I = FixId+-- ^ Semantically, we can say that @'I' = 'Fix' 'Id'@.+type instance PF I = Id++instance Mu I where+   inn = id+   out = id++data K a = FixConst {unFixConst :: a}+-- ^ Semantically, we can say that @'K' t = 'Fix' ('Const' t)@.+type instance PF (K a) = Const a++instance Mu (K a) where+   inn = FixConst+   out = unFixConst++infixr 5 :+!:+data (a :+!: b) = FixSum {unFixSum :: F (a :+!: b) (a :+!: b)}+-- ^ Semantically, we can say that @'Fix' f :+!: 'Fix' g = 'Fix' (f :+: g)@.+type instance PF (a :+!: b) = PF a :+: PF b++instance Mu (a :+!: b) where+   inn = FixSum+   out = unFixSum++infixr 6 :*!:+data (a :*!: b) = FixProd {unFixProd :: F (a :*!: b) (a :*!: b)}+-- ^ Semantically, we can say that @'Fix' f :*!: 'Fix' g = 'Fix' (f :*: g)@.+type instance PF (a :*!: b) = PF a :*: PF b++instance Mu (a :*!: b) where+   inn = FixProd+   out = unFixProd++infixr 9 :@!:+data (a :@!: b) = FixComp {unFixComp :: F (a :@!: b) (a :@!: b)}+-- ^ Semantically, we can say that @'Fix' f :\@!: 'Fix' g = 'Fix' (f ':\@: g)@.+type instance PF (a :@!: b) = PF a :@: PF b++instance Mu (a :@!: b) where+   inn = FixComp+   out = unFixComp++-- * Default definitions for commonly used data types++-- ** List++type instance PF [a] = Const One :+: Const a :*: Id++instance Mu [a] where+    inn (Left _) = []+    inn (Right (x,xs)) = x:xs+    out [] = Left _L+    out (x:xs) = Right (x,xs)++nil :: One -> [a]+nil = inn . inl++cons :: (a,[a]) -> [a]+cons = inn . inr++-- ** Int++type instance PF Int = Const One :+: Id++instance (Mu Int) where+    inn (Left _) = 0+    inn (Right n) = succ n+    out 0 = Left _L+    out n = Right (pred n)++zero :: One -> Int+zero = inn . inl++suck :: Int -> Int+suck = inn . inr++-- ** Bool++type instance PF Bool = Const One :+: Const One++instance Mu Bool where+	inn (Left _) = True+	inn (Right _) = False+	out True = Left _L+	out False = Right _L++true :: One -> Bool+true = inn . inl++false :: One -> Bool+false = inn . inr++-- ** Maybe++type instance PF (Maybe a) = Const One :+: Const a++instance Mu (Maybe a) where+    inn (Left _) = Nothing+    inn (Right x) = Just x+    out Nothing = Left _L+    out (Just x) = Right x++maybe2bool :: Maybe a -> Bool+maybe2bool = inn . (id -|- bang) . out
+ src/Generics/Pointless/Observe/Functors.hs view
@@ -0,0 +1,114 @@++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.Pointless.Observe.Functors+-- Copyright   :  (c) 2008 University of Minho+-- License     :  BSD3+--+-- Maintainer  :  hpacheco@di.uminho.pt+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Pointless Haskell:+-- point-free programming with recursion patterns as hylomorphisms+-- +-- This module defines generic GHood observations for user-defined data types.+--+-----------------------------------------------------------------------------++module Generics.Pointless.Observe.Functors where++import Generics.Pointless.Combinators+import Generics.Pointless.Functors+import Debug.Observe+import Data.Typeable+import Prelude hiding (Functor(..))++-- * Definition of generic observations++instance Typeable One where+   typeOf _ = (mkTyCon "One") `mkTyConApp` []++-- | Class for mapping observations over functor representations.+class FunctorO f where+   -- | Derives a type representation for a functor. This is used for showing the functor for reursion trees.+   functorOf :: Fix f -> String+   -- | Watch values of a functor. Since the fixpoint of a functor recurses over himself, we cannot use the 'Show' instance for functor values applied to their fixpoint.+   watch :: Fix f -> x -> Rep f x -> String+   -- | Maps an observation over a functor representation.+   fmapO :: Fix f -> (x -> ObserverM y) -> Rep f x -> ObserverM (Rep f y)++instance FunctorO Id where+   functorOf _ = "Id"+   watch _ _ _ = ""+   fmapO _ f x = f x++instance (Typeable a,Observable a) => FunctorO (Const a) where+   functorOf _ = "Const " ++ show (typeOf (_L::a))+   watch _ _ _ = ""+   fmapO _ f x = thunk x+++instance (FunctorO f, FunctorO g) => FunctorO (f :+: g) where+   functorOf _ = "(" ++ functorOf (_L::Fix f) ++ ":+:" ++ functorOf (_L::Fix g) ++ ")"+   watch _ _ (Left _) = "Left"+   watch _ _ (Right _) = "Right"+   fmapO _ f (Left x) = fmapO (_L::Fix f) f x >>= return . Left+   fmapO _ f (Right x) = fmapO (_L::Fix g) f x >>= return . Right++instance (FunctorO f, FunctorO g) => FunctorO (f :*: g) where+   functorOf _ = "(" ++ functorOf (_L::Fix f) ++ ":*:" ++ functorOf (_L::Fix g) ++ ")"+   watch _ _ _ = ""+   fmapO _ f (x,y) = do x' <- fmapO (_L :: Fix f) f x+			y' <- fmapO (_L::Fix g) f y+			return (x',y')++instance (FunctorO g, FunctorO h) => FunctorO (g :@: h) where+   functorOf _ = "(" ++ functorOf (_L::Fix g) ++ ":@:" ++ functorOf (_L::Fix h) ++ ")"+   watch _ (x::x) a = watch (_L::Fix g) (_L::Rep h x) a+   fmapO _ f x = fmapO (_L::Fix g) (fmapO (_L::Fix h) f) x++--w :: Fix (g:@:h) -> x -> Rep (g:@:h) x -> String+--w (_::Fix (g:@:h)) (r::x) (x) = watch (_L::Fix g) (aux x) x+--   where aux :: Rep (g:@:h) x -> Rep h x+--         aux _ = _L++-- | Polytypic mapping of observations.+omap :: FunctorO (PF a) => a -> (x -> ObserverM y) -> F a x -> ObserverM (F a y)+omap (_::a) f = fmapO (_L::Fix (PF a)) f++instance Observable One where+   observer = observeBase++instance Observable I where+   observer FixId = send "" (fmapO (_L :: Fix Id) thunk FixId)++instance (Typeable a,Observable a) => Observable (K a) where+   observer (FixConst a) = send "" (fmapO (_L::Fix (Const a)) thk a >>= return . FixConst)+      where thk = thunk :: a -> ObserverM a++instance (FunctorO (PF a),FunctorO (PF b)) => Observable (a :+!: b) where+   observer (FixSum f) = send "" (fmapO (_L::Fix (PF a :+: PF b)) thk f >>= return . FixSum)+      where thk = thunk :: a :+!: b -> ObserverM (a :+!: b)++instance (FunctorO (PF a), FunctorO (PF b)) => Observable (a :*!: b) where+   observer (FixProd f) = send "" (fmapO (_L::Fix (PF a :*: PF b)) thk f >>= return . FixProd)+      where thk = thunk :: a :*!: b -> ObserverM (a :*!: b)++instance (FunctorO (PF a), FunctorO (PF b)) => Observable (a :@!: b) where+   observer (FixComp f) = send "" (fmapO (_L::Fix (PF a :@: PF b)) thk f >>= return . FixComp)+      where thk = thunk :: a :@!: b -> ObserverM (a :@!: b)++-- NOTE: The following commented instance causes overlapping problems with the specific ones defined for base types (One,Int,etc.).+-- The solution is to provide its specific case for each type when needed, or to uncomment the following code+-- and using the flag -XIncoherentInstances.++--instance (Mu a,FunctorO (PF a)) => Observable a where+--   observer x = send "" (omap (_L :: a) thk (out x) >>= return . inn)+--      where thk = thunk :: a -> ObserverM a++instance (Functor f, FunctorO f) => Observable (Fix f) where+   observer (Fix x) = send (watch (_L::Fix f) (_L::Fix f) x) (fmapO (_L::Fix f) thk x >>= return . Fix)+      where thk = thunk :: Fix f -> ObserverM (Fix f)++
+ src/Generics/Pointless/Observe/RecursionPatterns.hs view
@@ -0,0 +1,91 @@++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.Pointless.Observe.RecursionPatterns+-- Copyright   :  (c) 2008 University of Minho+-- License     :  BSD3+--+-- Maintainer  :  hpacheco@di.uminho.pt+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Pointless Haskell:+-- point-free programming with recursion patterns as hylomorphisms+-- +-- This module redefines recursion patterns with support for GHood observation of intermediate data structures.+--+-----------------------------------------------------------------------------++module Generics.Pointless.Observe.RecursionPatterns where++import Generics.Pointless.Combinators+import Generics.Pointless.Functors+import Generics.Pointless.RecursionPatterns+import Debug.Observe+import Generics.Pointless.Observe.Functors+import Prelude hiding (Functor (..))+import Data.Typeable++-- * Recursion patterns with observation of intermediate data structures++-- | Redefinition of hylomorphisms with observation of the intermediate data type.+hyloO :: (Mu b, Functor (PF b), FunctorO (PF b)) => b -> (F b c -> c) -> (a -> F b a) -> a -> c+hyloO (b::b) g h = cata f g . observe ("Recursion Tree Functor: " ++ functorOf f) . ana f h+   where f = _L :: Fix (PF b)++-- | Redefinition of catamorphisms as observable hylomorphisms.+cataO :: (Mu a, Functor (PF a), FunctorO (PF a)) => a -> (F a b -> b) -> a -> b+cataO a f = hyloO a f out++-- | Redefinition of anamorphisms as observable hylomorphisms.+anaO :: (Mu b,Functor (PF b), FunctorO (PF b)) => b -> (a -> F b a) -> a -> b+anaO b f = hyloO b inn f++-- | Redefinition of paramorphisms as observable hylomorphisms.+paraO :: (Mu a,Functor (PF a), FunctorO (PF a), Observable a, Typeable a) => a -> (F a (b,a) -> b) -> a -> b+paraO (a::a) f = hyloO (_L :: Para a) f (pmap a (idA /\ idA) . out)+   where idA :: a -> a+         idA = id++-- | Redefinition of apomorphisms as observable hylomorphisms.+apoO :: (Mu b,Functor (PF b), FunctorO (PF b), Observable b, Typeable b) => b -> (a -> F b (Either a b)) -> a -> b+apoO (b::b) f = hyloO (_L :: Apo b) (inn . pmap b (idB \/ idB)) f+   where idB :: b -> b+         idB = id++-- | Redefinition of zygomorphisms as observable hylomorphisms.+zygoO :: (Mu a, Functor (PF a), FunctorO (PF a), Observable b, Typeable b, F a (a,b) ~ F (Zygo a b) a) => a -> (F a b -> b) -> (F (Zygo a b) b -> b) -> a -> b+zygoO a g f = aux a (_L :: b) g f+   where aux :: (Mu a,Functor (PF a), FunctorO (PF a),Observable b, Typeable b, F a (a,b) ~ F (Zygo a b) a) => a -> b -> (F a b -> b) -> (F (Zygo a b) b -> b) -> a -> b+         aux (a::a) (b::b) g f = hyloO (_L :: Zygo a b) f (pmap a (id /\ cata a g) . out)++-- | Redefinition of accumulations as observable hylomorphisms.+accumO :: (Mu a,Functor (PF d), FunctorO (PF d), Observable b, Typeable b) => d -> ((F a a,b) -> F d (a,b)) -> (F (Accum d b) c -> c) -> (a,b) -> c+accumO (d::d) g f = hyloO (_L :: Accum d b) f ((g /\ snd) . (out >< id))++-- | Redefinition of histomorphisms as observable hylomorphisms.+histoO :: (Mu a,Functor (PF a), FunctorO (PF a), Observable a) => a -> (F a (Histo a c) -> c) -> a -> c+histoO (a::a) g = fst . outH . cataO a (inn . (g /\ id))+   where outH :: Histo a c -> F (Histo a c) (Histo a c)+         outH = out++-- | Redefinition of futumorphisms as observable hylomorphisms.+futuO :: (Mu b,Functor (PF b), FunctorO (PF b), Observable b) => b -> (a -> F b (Futu b a)) -> a -> b+futuO (b::b) g = anaO b ((g \/ id) . out) . innF . inl+   where innF :: F (Futu b a) (Futu b a) -> Futu b a+         innF = inn++-- | Redefinition of dynamorphisms as observable hylomorphisms.+dynaO :: (Mu b, Functor (PF b), FunctorO (PF b), Observable b) => b -> (F b (Histo b c) -> c) -> (a -> F b a) -> a -> c+dynaO (b::b) g h = fst . outH . hyloO b (inn . (g /\ id)) h+   where outH :: Histo b c -> F (Histo b c) (Histo b c)+         outH = out++-- | Redefinition of chronomorphisms as observable hylomorphisms.+chronoO :: (Mu c,Functor (PF c), FunctorO (PF c)) => c -> (F c (Histo c b) -> b) -> (a -> F c (Futu c a)) -> a -> b+chronoO (c::c) g h = fst . outH . hyloO c (inn . (g /\ id)) ((h \/ id) . out) . innF . inl+   where outH :: Histo c b -> F (Histo c b) (Histo c b)+         outH = out+         innF :: F (Futu c a) (Futu c a) -> (Futu c a)+         innF = inn+
+ src/Generics/Pointless/RecursionPatterns.hs view
@@ -0,0 +1,205 @@++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.Pointless.RecursionPatterns+-- Copyright   :  (c) 2008 University of Minho+-- License     :  BSD3+--+-- Maintainer  :  hpacheco@di.uminho.pt+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Pointless Haskell:+-- point-free programming with recursion patterns as hylomorphisms+-- +-- This module defines recursion patterns as hylomorphisms.+--+-- Recursion patterns can be seen as high-order functions that encapsulate typical forms of recursion.+-- The hylomorphism recursion pattern was first defined in <http://research.microsoft.com/~emeijer/Papers/CWIReport.pdf>,+-- along with its relation with derived more specific recursion patterns such as catamorphisms, anamorphisms and paramorphisms.+--+-- The seminal paper that introduced point-free programming and defined many of the laws for catamorphisms and anamorphisms+-- can be found in <http://eprints.eemcs.utwente.nl/7281/01/db-utwente-40501F46.pdf>.+--+-- More complex and exotic recursion patterns have been discovered later, such as accumulations, apomorphisms, zygomorphisms,+-- histomorphisms, futumorphisms, dynamorphisms or chronomorphisms.+--+-----------------------------------------------------------------------------++module Generics.Pointless.RecursionPatterns where++import Generics.Pointless.Combinators+import Generics.Pointless.Functors+import Control.Monad.Instances hiding (Functor(..))+import Prelude hiding (Functor(..))++-- | Definition of an hylomorphism+hylo :: Functor (PF b) => b -> (F b c -> c) -> (a -> F b a) -> a -> c+hylo b g h = g . pmap b (hylo b g h) . h++-- | Definition of a catamorphism as an hylomorphism.+--+-- Catamorphisms model the fundamental pattern of iteration, where constructors for recursive datatypes are repeatedly consumed by arbitrary functions.+-- They are usually called folds.+cata :: (Mu a,Functor (PF a)) => a -> (F a b -> b) -> a -> b+cata a f = hylo a f out++-- | Recursive definition of a catamorphism.+cataRec :: (Mu a,Functor (PF a)) => a -> (F a b -> b) -> a -> b+cataRec a f = f . pmap a (cataRec a f) . out++-- | Definition of an anamorphism as an hylomorphism.+--+--  Anamorphisms resembles the dual of iteration and, hence, define the inverse of catamorphisms.+-- Instead of consuming recursive types, they produce values of those types.+ana :: (Mu b,Functor (PF b)) => b -> (a -> F b a) -> a -> b+ana b f = hylo b inn f++-- | Recursive definition of an anamorphism.+anaRec :: (Mu b,Functor (PF b)) => b -> (a -> F b a) -> a -> b+anaRec b f = inn . pmap b (anaRec b f) . f++-- | The functor of intermediate type of a paramorphism is the functor of the consumed type 'a'+-- extended with an extra annotation to itself in recursive definitions.+type Para a = a :@!: (I :*!: K a)++-- | Definition of a paramorphism.+--+-- Paramorphisms supply the gene of a catamorphism with a recursively computed copy of the input.+--+-- The first introduction to paramorphisms is reported in <http://www.cs.uu.nl/research/techreps/repo/CS-1990/1990-04.pdf>.+para :: (Mu a,Functor (PF a)) => a -> (F a (b,a) -> b) -> a -> b+para (a::a) f = hylo (_L :: Para a) f (pmap a (idA /\ idA) . out)+   where idA :: a -> a+         idA = id++-- | Recursive definition of a paramorphism.+paraRec :: (Mu a,Functor (PF a)) => a -> (F a (b,a) -> b) -> a -> b+paraRec (a::a) f = f . pmap a (paraRec a f >< idA) . pmap a (idA /\ idA) . out+   where idA :: a -> a+         idA = id++-- | The functor of intermediate type of a paramorphism is the functor of the generated type 'b'+-- with an alternative annotation to itself in recursive definitions.+type Apo b = b :@!: (I :+!: K b)++-- | Definition of an apomorphism as an hylomorphism.+--+-- Apomorphisms are the dual recursion patterns of paramorphisms, and therefore they can express functions defined by primitive corecursion.+--+-- They were introduced independently in <http://www.cs.ut.ee/~varmo/papers/nwpt97.ps.gz> and /Program Construction and Generation Based on Recursive Types, MSc thesis/.+apo :: (Mu b,Functor (PF b)) => b -> (a -> F b (Either a b)) -> a -> b+apo (b::b) f = hylo (_L :: Apo b) (inn . pmap b (idB \/ idB)) f+   where idB :: b -> b+         idB = id++-- | Recursive definition of an apomorphism.+apoRec :: (Mu b,Functor (PF b)) => b -> (a -> F b (Either a b)) -> a -> b+apoRec (b::b) f = (inn . pmap b (idB \/ idB) . pmap b (apoRec b f -|- idB) . f)+   where idB :: b -> b+         idB = id++-- | In zygomorphisms we extend the recursive occurences in the base functor functor of type 'a' with an extra annotation 'b'.+type Zygo a b = a :@!: (I :*!: K b)++-- | Definition of a zygomorphism as an hylomorphism.+--+-- Zygomorphisms were introduced in <http://dissertations.ub.rug.nl/faculties/science/1990/g.r.malcolm/>.+--+-- They can be seen as the asymmetric form of mutual iteration, where both a data consumer and an auxiliary function are defined (<http://www.fing.edu.uy/~pardo/papers/njc01.ps.gz>).+zygo :: (Mu a, Functor (PF a),F a (a,b) ~ F (Zygo a b) a) => a -> (F a b -> b) -> (F (Zygo a b) b -> b) -> a -> b+zygo a g f = aux a (_L :: b) g f+   where aux :: (Mu a,Functor (PF a),F a (a,b) ~ F (Zygo a b) a) => a -> b -> (F a b -> b) -> (F (Zygo a b) b -> b) -> a -> b+         aux (a::a) (b::b) g f = hylo (_L :: Zygo a b) f (pmap a (id /\ cata a g) . out)++-- | In accumulations we add an extra annotation 'b' to the base functor of type 'a'.+type Accum a b = a :*!: K b++-- | Definition of an accumulation as an hylomorphism.+--+-- Accumulations <http://www.fing.edu.uy/~pardo/papers/wcgp02.ps.gz> are binary functions that use the second parameter to store intermediate results.+--+-- The so called "accumulation technique" is tipically used in functional programming to derive efficient implementations of some recursive functions.+accum :: (Mu a,Functor (PF d)) => d -> ((F a a,b) -> F d (a,b)) -> (F (Accum d b) c -> c) -> (a,b) -> c+accum (d::d) g f = hylo (_L :: Accum d b) f ((g /\ snd) . (out >< id))++-- | In histomorphisms we add an extra annotation 'c' to the base functor of type 'a'.+type Histo a c = K c :*!: a++-- | Definition of an histomorphism as an hylomorphism (as long as the catamorphism is defined as an hylomorphism).+--+-- Histomorphisms (<http://cs.ioc.ee/~tarmo/papers/inf.ps.gz>) capture the powerfull schemes of course-of-value iteration, and differ from catamorphisms for being able to apply the gene function at a deeper depth of recursion.+-- In other words, they allow to reuse sub-sub constructor results.+histo :: (Mu a,Functor (PF a)) => a -> (F a (Histo a c) -> c) -> a -> c+histo (a::a) g = fst . outH . cata a (inn . (g /\ id))+   where outH :: Histo a c -> F (Histo a c) (Histo a c)+         outH = out++-- | The combinator 'outl' unpacks the functor of an histomorphism and selects the annotation.+outl :: Histo a c -> c+outl = fst . out++-- | The combinator 'outr' unpacks the functor of an histomorphism and discards the annotation.+outr :: Histo a c -> F a (Histo a c)+outr = snd . out++-- | In futumorphisms we add an alternative annotation 'c' to the base functor of type 'b'.+type Futu b c = K c :+!: b++-- | Definition of a futumorphism as an hylomorphism (as long as the anamorphism is defined as an hylomorphism).+--+-- Futumorphisms are the dual of histomorphisms and are proposed as 'cocourse-of-argument' coiterators by their creators (<http://cs.ioc.ee/~tarmo/papers/inf.ps.gz>).+--+-- In the same fashion as histomorphisms, it allows to seed the gene with multiple levels of depth instead of having to do 'all at once' with an anamorphism.+futu :: (Mu b,Functor (PF b)) => b -> (a -> F b (Futu b a)) -> a -> b+futu (b::b) g = ana b ((g \/ id) . out) . innF . inl+   where innF :: F (Futu b a) (Futu b a) -> Futu b a+         innF = inn++-- | The combinator 'innl' packs the functor of a futumorphism from the base functor.+innl :: c -> Futu b c+innl = inn . inl++-- | The combinator 'innr' packs the functor of an futumorphism from an annotation.+innr :: F b (Futu b c) -> Futu b c+innr = inn . inr++-- | Definition of a dynamorphism as an hylomorphisms.+--+-- Dynamorphisms (<http://math.ut.ee/~eugene/kabanov-vene-mpc-06.pdf>) are a more general form of histomorphisms for capturing dynaming programming constructions.+--+-- Instead of following the recursion pattern of the input via structural recursion (as in histomorphisms),+-- dynamorphisms allow us to reuse the annotated structure in a bottom-up approach and avoiding rebuilding+-- it every time an annotation is needed, what provides a more efficient dynamic algorithm.+dyna :: (Mu b, Functor (PF b)) => b -> (F b (Histo b c) -> c) -> (a -> F b a) -> a -> c+dyna (b::b) g h = fst . outH . hylo b (inn . (g /\ id)) h+   where outH :: Histo b c -> F (Histo b c) (Histo b c)+         outH = out++-- | Definition of a chronomorphism as an hylomorphism.+--+-- This recursion pattern subsumes histomorphisms, futumorphisms and dynamorphisms+-- and can be seen as the natural hylomorphism generalization from composing an histomorphism after a futumorphism.+-- Therefore, chronomorphisms can 'look back' when consuming a type and 'jump forward' when generating one, via it's fold/unfold operations, respectively.+--+-- The notion of chronomorphism is a recent recursion pattern (at least known as such).+-- The first and single reference available is <http://comonad.com/reader/2008/time-for-chronomorphisms/>.+chrono :: (Mu c,Functor (PF c)) => c -> (F c (Histo c b) -> b) -> (a -> F c (Futu c a)) -> a -> b+chrono (c::c) g h = fst . outH . hylo c (inn . (g /\ id)) ((h \/ id) . out) . innF . inl+   where outH :: Histo c b -> F (Histo c b) (Histo c b)+         outH = out+         innF :: F (Futu c a) (Futu c a) -> (Futu c a)+         innF = inn++-- | The Fixpoint combinator as an hylomorphism.+--+-- 'fix' is a fixpoint combinator if @'fix' = 'app' '.' ('id' '/\' 'fix')@.+--+-- After expanding the definitions of '.', '/\' and 'app' we see that this corresponds to the expected pointwise equation @'fix' f = f ('fix' f)@.+fix :: (a -> a) -> a+fix = hylo (_L :: K (a -> a) :*!: I) app (id /\ id)++-- | The combinator for isomorphic type transformations.+--+-- It can translate between types that share the same functor.+nu d = (inn . pmap d nu . out) d