Sat Dec 6 20:23:32 WET 2008 hpacheco@di.uminho.pt
* Initial import
{
addfile ./LICENSE
addfile ./README
addfile ./Setup.lhs
addfile ./Test.hs
addfile ./pointless-haskell.cabal
adddir ./src
adddir ./src/Generics
adddir ./src/Generics/Pointless
addfile ./src/Generics/Pointless/Combinators.hs
adddir ./src/Generics/Pointless/Examples
addfile ./src/Generics/Pointless/Examples/Examples.hs
addfile ./src/Generics/Pointless/Examples/Observe.hs
addfile ./src/Generics/Pointless/Functors.hs
adddir ./src/Generics/Pointless/Observe
addfile ./src/Generics/Pointless/Observe/Functors.hs
addfile ./src/Generics/Pointless/Observe/RecursionPatterns.hs
addfile ./src/Generics/Pointless/RecursionPatterns.hs
hunk ./LICENSE 1
+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.
hunk ./README 1
+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
+...
+
hunk ./Setup.lhs 1
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
hunk ./Test.hs 1
+module Test where
+
+import Generics.Pointless.Examples.Examples
+import Generics.Pointless.Examples.GHood
hunk ./pointless-haskell.cabal 1
+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
hunk ./src/Generics/Pointless/Combinators.hs 1
+
+-----------------------------------------------------------------------------
+-- |
+-- 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)
+
hunk ./src/Generics/Pointless/Examples/Examples.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- 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 âdiï¬erenceâ 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)?)
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
hunk ./src/Generics/Pointless/Examples/Observe.hs 1
+
+-----------------------------------------------------------------------------
+-- |
+-- 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
+[_^I_][_$_]
+-- | 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
+
+
hunk ./src/Generics/Pointless/Functors.hs 1
+
+-----------------------------------------------------------------------------
+-- |
+-- 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
hunk ./src/Generics/Pointless/Observe/Functors.hs 1
+
+-----------------------------------------------------------------------------
+-- |
+-- 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)
+
+
hunk ./src/Generics/Pointless/Observe/RecursionPatterns.hs 1
+
+-----------------------------------------------------------------------------
+-- |
+-- 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
+
hunk ./src/Generics/Pointless/RecursionPatterns.hs 1
+
+-----------------------------------------------------------------------------
+-- |
+-- 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, deï¬ne 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 deï¬ned 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 deï¬nitions 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
}