hyperfunctions (empty) → 0

raw patch · 11 files changed

+581/−0 lines, 11 filesdep +adjunctionsdep +basedep +distributivesetup-changed

Dependencies added: adjunctions, base, distributive, profunctors, transformers

Files

• .ghci +1/−0
• .gitignore +17/−0
• .travis.yml +40/−0
• CHANGELOG.markdown +5/−0
• LICENSE +26/−0
• README.markdown +13/−0
• Setup.hs +2/−0
• examples/Cantor.hs +95/−0
• hyperfunctions.cabal +43/−0
• src/Control/Monad/Hyper.hs +143/−0
• src/Control/Monad/Hyper/Rep.hs +196/−0

@@ -0,0 +1,1 @@+:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h

@@ -0,0 +1,17 @@+dist/+.hsenv/+docs+wiki+TAGS+tags+wip+.DS_Store+.*.swp+.*.swo+*.o+*.hi+*~+*#+.cabal-sandbox/+cabal.sandbox.config+codex.tags

@@ -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"

@@ -0,0 +1,5 @@+# 0++* Repository initialized++

@@ -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.

@@ -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

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,95 @@+{-# LANGUAGE RankNTypes #-}++-- | <http://math.andrej.com/2009/10/12/constructive-gem-double-exponentials/ Constructive gem: double exponentials>++module Cantor+  ( _Natural+  ) where++import Control.Monad.Hyper+import Data.Profunctor+import Numeric.Natural++type Cantor = Natural -> Bool+type Functional = Cantor -> Bool++-- | <http://math.andrej.com/2007/09/28/seemingly-impossible-functional-programs/ Seemingly impossible functional programs>+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"

@@ -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 <ekmett@gmail.com>+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

@@ -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 <ekmett@gmail.com>+-- 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++-- |+-- <http://arxiv.org/pdf/1309.5135.pdf Under nice conditions:>+--+-- @+-- 'fold' . 'build' ≡ 'id'+-- @+build :: (forall b c. (a -> b -> c) -> c -> Hyper b c) -> [a]+build g = run (g (:) [])

@@ -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 <ekmett@gmail.com>+-- 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))++-- |+-- <http://arxiv.org/pdf/1309.5135.pdf Under "nice" conditions>+--+-- @+-- '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 (:) [])