diff --git a/.ghci b/.ghci new file mode 100644 --- /dev/null +++ b/.ghci @@ -0,0 +1,1 @@ +:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,17 @@ +dist/ +.hsenv/ +docs +wiki +TAGS +tags +wip +.DS_Store +.*.swp +.*.swo +*.o +*.hi +*~ +*# +.cabal-sandbox/ +cabal.sandbox.config +codex.tags diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,40 @@ +env: + - GHCVER=7.8.4 CABALVER=1.18 + - GHCVER=7.10.1 CABALVER=1.22 + - GHCVER=head CABALVER=1.22 + +matrix: + allow_failures: + - env: GHCVER=head CABALVER=1.22 + +before_install: + - travis_retry sudo add-apt-repository -y ppa:hvr/ghc + - travis_retry sudo apt-get update + - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER + - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH + - cabal --version + +install: + - travis_retry cabal update + - cabal install --enable-tests --only-dependencies + +script: + - cabal configure -v2 --enable-tests + - cabal build + - cabal sdist + - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; + cd dist/; + if [ -f "$SRC_TGZ" ]; then + cabal install "$SRC_TGZ"; + else + echo "expected '$SRC_TGZ' not found"; + exit 1; + fi + +notifications: + irc: + channels: + - "irc.freenode.org#haskell-lens" + skip_join: true + template: + - "\x0313hyperfunctions\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f" diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -0,0 +1,5 @@ +# 0 + +* Repository initialized + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright 2015 Edward Kmett + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. 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. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,13 @@ +hyperfunctions +============== + +[![Build Status](https://secure.travis-ci.org/ekmett/hyperfunctions.png?branch=master)](http://travis-ci.org/ekmett/hyperfunctions) + +Contact Information +------------------- + +Contributions and bug reports are welcome! + +Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. + +-Edward Kmett diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Cantor.hs b/examples/Cantor.hs new file mode 100644 --- /dev/null +++ b/examples/Cantor.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE RankNTypes #-} + +-- | + +module Cantor + ( _Natural + ) where + +import Control.Monad.Hyper +import Data.Profunctor +import Numeric.Natural + +type Cantor = Natural -> Bool +type Functional = Cantor -> Bool + +-- | +find :: Functional -> Cantor +find p = branch x0 l0 (find (\r -> p (branch x0 l0 r))) where + x0 = forsome (\l -> forsome (\r -> p (branch True l r))) + l0 = find (\l -> forsome (\r -> p (branch x0 l r))) + branch x _ _ 0 = x + branch _ l r n + | odd n = l ((n - 1) `div` 2) + | otherwise = r ((n - 2) `div` 2) + +forevery, forsome :: Functional -> Bool +forsome f = f (find f) +forevery f = not (forsome (not . f)) + +type Iso' s a = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s) + +-- | Inductive Hyper functions from Bool to Bool are isomorphic to the natural numbers. +_Natural :: Iso' Natural (Hyper Bool Bool) +_Natural = dimap (ana enum) (fmap (cata denum)) where + + unpair :: Natural -> (Natural, Natural) + unpair 0 = (0, 0) + unpair n = (xr + 2*x, yr + 2*y) where + (p, xr) = divMod n 2 + (q, yr) = divMod p 2 + (x, y) = unpair q + + enum :: Natural -> Functional + enum 0 = const False + enum 1 = const True + enum n0 = fn' (n0-2) where + fn' f a = compute 0 f where + compute k 0 = not (a k) + compute k 1 = a k + compute k n | n' <- n - 2, q <- div n' 5 = case mod n' 5 of + 0 -> not (a k) && compute (k+1) q + 1 -> a k && compute (k+1) q + 2 -> not (a k) || compute (k+1) q + 3 -> a k || compute (k+1) q + 4 | (x, y) <- unpair q -> if a k + then compute (k+1) y + else compute (k+1) x + + pair :: Natural -> Natural -> Natural + pair 0 0 = 0 + pair m n = mr + 2 * nr + 4 * pair mq nq where + (mq, mr) = divMod m 2 + (nq, nr) = divMod n 2 + + shift :: Bool -> Functional -> Functional + shift b f = f . prepend b + prepend b _ 0 = b + prepend _ a n = a (n-1) + + getConst :: Functional -> Maybe Bool + getConst f + | forevery (\a -> f a == b) = Just b + | otherwise = Nothing + where b = f (const False) + + denum :: Functional -> Natural + denum f0 = case getConst f0 of + Just False -> 0 + Just True -> 1 + Nothing -> 2 + go f0 where + go f + | a <- shift False f + , b <- shift True f = case getConst a of + Nothing -> case getConst b of + Nothing -> 6 + 5 * pair (go a) (go b) + Just False -> 2 + 5 * go a + Just True -> 5 + 5 * go a + Just False -> case getConst b of + Nothing -> 3 + 5 * go b + Just False -> error "impossible" + Just True -> 1 + Just True -> case getConst b of + Nothing -> 4 + 5 * go b + Just False -> 0 + Just True -> error "impossible" diff --git a/hyperfunctions.cabal b/hyperfunctions.cabal new file mode 100644 --- /dev/null +++ b/hyperfunctions.cabal @@ -0,0 +1,43 @@ +name: hyperfunctions +category: Control, Categories +version: 0 +license: BSD3 +cabal-version: >= 1.8 +license-file: LICENSE +author: Edward A. Kmett +maintainer: Edward A. Kmett +stability: provisional +homepage: http://github.com/ekmett/hyperfunctions +bug-reports: http://github.com/ekmett/hyperfunctions/issues +copyright: Copyright (C) 2015 Edward A. Kmett +build-type: Simple +tested-with: GHC == 7.8.4 +synopsis: Hyperfunctions +description: Hyperfunctions +extra-source-files: + .ghci + .travis.yml + .gitignore + README.markdown + CHANGELOG.markdown + examples/Cantor.hs + +source-repository head + type: git + location: git://github.com/ekmett/hyperfunctions.git + +library + build-depends: + adjunctions >= 4.2.1 && < 5, + base >= 4.7 && < 5, + distributive >= 0.4.4 && < 1, + profunctors >= 5 && < 6, + transformers >= 0.3 && < 0.5 + + hs-source-dirs: src + + exposed-modules: + Control.Monad.Hyper + Control.Monad.Hyper.Rep + + ghc-options: -Wall diff --git a/src/Control/Monad/Hyper.hs b/src/Control/Monad/Hyper.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Hyper.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +-- +----------------------------------------------------------------------------- + +module Control.Monad.Hyper where + +import Control.Applicative +import Control.Arrow +import Control.Category +import Control.Monad.Fix +import Control.Monad.Zip +import Data.Coerce +import Data.Profunctor +import Prelude hiding ((.),id) + + +-- | +-- +-- @ +-- 'invoke' f g ≡ 'run' (f . g) +-- 'arr' f ≡ 'push' f ('arr' f) +-- 'invoke' 'id' 'id' ≡ _|_ +-- @ +-- +-- 'arr' is a faithful functor, so @'arr' f ≡ 'arr' g@ implies @f ≡ g@ +newtype Hyper a b = Hyper { invoke :: Hyper b a -> b } + +unroll :: Hyper a b -> (Hyper a b -> a) -> b +unroll = coerce + +roll :: ((Hyper a b -> a) -> b) -> Hyper a b +roll = coerce + +ana :: (x -> (x -> a) -> b) -> x -> Hyper a b +ana psi = f where f x = Hyper $ \z -> psi x (invoke z . f) + +-- | From "Generalizing the augment combinator" by Ghani, Uustali and Vene. +-- +-- @ +-- 'cata' phi ('push' f h) ≡ phi $ \\g -> f $ g ('cata' phi h) +-- @ +cata :: (((x -> a) -> b) -> x) -> Hyper a b -> x +cata phi = f where f h = phi $ \g -> unroll h (g . f) + +instance Category Hyper where + id = arr id + f . g = Hyper $ \k -> invoke f (g . k) + +instance Profunctor Hyper where + dimap f g h = Hyper $ g . invoke h . dimap g f + lmap f h = Hyper $ invoke h . rmap f + rmap f h = Hyper $ f . invoke h . lmap f + +instance Arrow Hyper where + arr = fix . push + first = ana $ \i fac -> (unroll i (fst . fac), snd (fac i)) + second = ana $ \i fca -> (fst (fca i), unroll i (snd . fca)) + (***) = curry $ ana $ \(i,j) fgac -> (unroll i $ \i' -> fst $ fgac (i',j), unroll j $ \j' -> snd $ fgac (i,j')) + (&&&) = curry $ ana $ \(i,j) fga -> (unroll i $ \i' -> fga (i',j), unroll j $ \j' -> fga (i,j')) + +instance ArrowLoop Hyper where + loop = ana (flip f') where + f' fa = fmap fst $ fix $ \r -> flip unroll $ \i -> (fa i, snd $ r i) + +instance Strong Hyper where + first' = first + second' = second + +instance Costrong Hyper where + unfirst = loop + +instance Functor (Hyper a) where + fmap = rmap + +instance Applicative (Hyper a) where + pure a = Hyper $ \_ -> a + p <* _ = p + _ *> p = p + (<*>) = curry $ ana $ \(i,j) fga -> + unroll i (\i' -> fga (i',j)) $ unroll j (\j' -> fga (i,j')) + +instance Monad (Hyper a) where + return = pure + m >>= f = cata (\g -> roll $ \k -> unroll (f (g k)) k) m + +instance MonadZip (Hyper a) where + munzip h = (fmap fst h, fmap snd h) + mzipWith = liftA2 + +-- | +-- @ +-- 'push' f p . 'push' g q ≡ 'push' (f . g) (p . q) +-- 'invoke' ('push' f p) q ≡ f ('invoke' q p) +-- @ +push :: (a -> b) -> Hyper a b -> Hyper a b +push f q = Hyper $ \k -> f (invoke k q) + + +-- | +-- +-- @ +-- 'run' ('arr' f) ≡ 'fix' f +-- 'run' ('push' f q) ≡ f ('run' q) +-- 'run' ('push' f p . q) ≡ f ('run' (q . p)) = f ('invoke' q p) +-- @ +run :: Hyper a a -> a +run f = invoke f id + +-- | +-- @ +-- 'project' ('push' f q) ≡ f +-- @ +-- +-- 'project' is a left inverse for 'arr': +-- +-- @ +-- 'project' '.' 'arr' ≡ 'id' +-- @ +project :: Hyper a b -> a -> b +project q x = invoke q (pure x) + +fold :: [a] -> (a -> b -> c) -> c -> Hyper b c +fold xs c n = foldr (push . c) (pure n) xs + +-- | +-- +-- +-- @ +-- 'fold' . 'build' ≡ 'id' +-- @ +build :: (forall b c. (a -> b -> c) -> c -> Hyper b c) -> [a] +build g = run (g (:) []) diff --git a/src/Control/Monad/Hyper/Rep.hs b/src/Control/Monad/Hyper/Rep.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Hyper/Rep.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +-- +-- Hyperfunctions as an explicit nu form, but using a representable functor +-- to describe the state space of the hyperfunction. This permits memoization +-- but doesn't require it. +-- +-- If we start with a 'function with state' @(x -> a) -> x -> b@ we can view +-- it as either @(x -> a, x) -> b@ wich is a @Store x@ Cokleisli morphism or +-- as @φ :: x -> (x -> a) -> b@ which given @H a b x = (x -> a) -> b@ is a +-- @(H a b)@-coalgebra: @(x, φ)@ . Given that we can think of anamorphisms of +-- this 'function with state' as giving us a fixed point for @H a b@ and the +-- morphism to the final coalgebra @(Hyper a b, ana φ) is unique (by definition). +-- +-- A representable functor @f@ is isomorphic to @(->) ('Rep' f)@. @((->) x)@ +-- is an obvious selection for such a representable functor, so if we switch +-- out the functions from 'x' in the above, for a representable functor with +-- @x@ as its representation we get opportunities for memoization on the +-- internal 'state space' of our hyperfunctions. +-- +----------------------------------------------------------------------------- +module Control.Monad.Hyper.Rep where + +import Control.Applicative +import Control.Arrow +import Control.Category +import Control.Monad.Fix +import Control.Monad.Zip +import Data.Distributive +import Data.Functor.Compose +import Data.Functor.Identity +import Data.Functor.Rep +import Data.Profunctor +import Data.Profunctor.Unsafe +import Prelude hiding ((.),id) + +-- | Represented Hyperfunctions +-- +-- 'arr' is a faithful functor, so +-- +-- @'arr' f ≡ 'arr' g@ implies @f ≡ g@ + +data Hyper a b where + Hyper :: Representable g => g (g a -> b) -> Rep g -> Hyper a b + +ana :: (x -> (x -> a) -> b) -> x -> Hyper a b +ana = Hyper + +-- | +-- @ +-- 'cata' phi ('push' f h) ≡ phi $ \\g -> f $ g ('cata' phi h) +-- @ +cata :: (((y -> a) -> b) -> y) -> Hyper a b -> y +cata = cata' + +-- | Memoizing catamorphism +cata' :: Representable f => ((f a -> b) -> Rep f) -> Hyper a b -> Rep f +cata' f (Hyper g x) = index h x where + h = fmap (\k -> f (\fx -> k $ fmap (index fx) h)) g + +instance Category Hyper where + id = Hyper (Identity runIdentity) () + Hyper f x . Hyper g y = Hyper + (Compose $ fmap (\phi -> fmap (\psi -> phi . fmap psi . getCompose) g) f) + (x,y) + +instance Arrow Hyper where + arr f = Hyper (Identity (f .# runIdentity)) () + + first (Hyper (f :: f (f a -> b)) x) = Hyper f' x where + f' :: forall c. f (f (a,c) -> (b,c)) + f' = tabulate $ \i fac -> (index f i (fmap fst fac), snd (index fac i)) + + second (Hyper (f :: f (f a -> b)) x) = Hyper f' x where + f' :: forall c. f (f (c,a) -> (c,b)) + f' = tabulate $ \i fca -> (fst (index fca i), index f i (fmap snd fca)) + + Hyper (f :: f (f a -> b)) x *** Hyper (g :: g (g c -> d)) y = Hyper h (x,y) where + h :: Compose f g (Compose f g (a,c) -> (b, d)) + h = tabulate $ \(i,j) (Compose fgac) -> + ( index f i (fmap (\gac -> fst (index gac j)) fgac) + , index g j (fmap snd (index fgac i)) + ) + + Hyper (f :: f (f a -> b)) x &&& Hyper (g :: g (g a -> c)) y = Hyper h (x,y) where + h :: Compose f g (Compose f g a -> (b, c)) + h = tabulate $ \(i,j) (Compose fga) -> + ( index f i (fmap (`index` j) fga) + , index g j (index fga i) + ) + +instance ArrowLoop Hyper where + loop (Hyper f x) = Hyper (distribute f') x where + f' fa = fmap fst $ fix $ \(r :: f (b,d)) -> + distribute f $ tabulate $ \i -> (index fa i, snd $ index r i) + +instance Functor (Hyper a) where + fmap f (Hyper h x) = Hyper (fmap (f .) h) x + +instance Applicative (Hyper a) where + pure b = Hyper (Identity (const b)) () + p <* _ = p + _ *> p = p + Hyper (f :: f (f a -> b -> c)) x <*> Hyper (g :: g (g a -> b)) y = Hyper h (x,y) where + h :: Compose f g (Compose f g a -> c) + h = tabulate $ \(i,j) (Compose fga) -> + index f i (fmap (`index` j) fga) (index g j (index fga i)) + +instance Monad (Hyper a) where + return = pure + m >>= f = cata (\g -> roll $ \k -> unroll (f (g k)) k) m + +instance MonadZip (Hyper a) where + munzip h = (fmap fst h, fmap snd h) + mzipWith = liftA2 + +instance Profunctor Hyper where + dimap f g (Hyper h x) = Hyper (fmap (\fa2b -> g . fa2b . fmap f) h) x + +instance Strong Hyper where + first' = first + second' = second + +instance Costrong Hyper where + unfirst = loop + +-- | +-- @ +-- 'arr' f ≡ 'push' f ('arr' f) +-- 'invoke' ('push' f q) k ≡ f ('invoke' k q) +-- 'push' f p . 'push' g q ≡ 'push' (f . g) (p . q) +-- @ +push :: (a -> b) -> Hyper a b -> Hyper a b +push f q = uninvoke $ \k -> f (invoke k q) + +-- | Unroll a hyperfunction +unroll :: Hyper a b -> (Hyper a b -> a) -> b +unroll (Hyper (f :: f (f a -> b)) x) k = index f x (tabulate (k . Hyper f)) + +-- | Re-roll a hyperfunction using Lambek's lemma. +roll :: ((Hyper a b -> a) -> b) -> Hyper a b +roll = Hyper (mapH unroll) where + -- mapH :: (x -> y) -> ((x -> a) -> b) -> (y -> a) -> b + mapH xy xa2b ya = xa2b (ya . xy) + + +invoke :: Hyper a b -> Hyper b a -> b +invoke (Hyper (f :: f (f a -> b)) x) (Hyper (g :: g (g b -> a)) y) = index (index r x) y where + -- tie a knot through state space + r = fmap (\phi -> fmap (\psi -> phi (fmap psi r)) g) f + +uninvoke :: (Hyper b a -> b) -> Hyper a b +uninvoke = Hyper (. roll) + +-- | +-- @ +-- 'run' f ≡ 'invoke' f 'id' +-- 'run' ('arr' f) ≡ 'fix' f +-- 'run' ('push' f q) ≡ f ('run' q) +-- 'run' ('push' f p . q) ≡ f ('run' (q . p)) = f ('invoke' q p) +-- @ +run :: Hyper a a -> a +run (Hyper f x) = index r x where r = fmap ($ r) f + + +-- | +-- @ +-- 'project' . 'arr' ≡ 'id' +-- 'project' h a ≡ 'invoke' h ('pure' a) +-- 'project' ('push' f q) ≡ f +-- @ +project :: Hyper a b -> a -> b +project (Hyper f x) a = index f x (tabulate (const a)) + +-- | +-- +-- +-- @ +-- 'fold' . 'build' ≡ 'id' +-- @ +fold :: [a] -> (a -> b -> c) -> c -> Hyper b c +fold [] _ n = pure n +fold (x:xs) c n = push (c x) (fold xs c n) + +build :: (forall b c. (a -> b -> c) -> c -> Hyper b c) -> [a] +build g = run (g (:) [])