diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,54 @@ +language: haskell + +env: + - GHCVER=7.6.3 + - GHCVER=7.8.1 + +matrix: + allow_failures: + - env: GHCVER=head + +before_install: + # If $GHCVER is the one travis has, don't bother reinstalling it. + # We can also have faster builds by installing some libraries with + # `apt`. If it isn't, install the GHC we want from hvr's PPA along + # with cabal-1.18. + - | + if [ $GHCVER = `ghc --numeric-version` ]; then + # Try installing some of the build-deps with apt-get for speed. + travis/cabal-apt-install --enable-tests $MODE + export CABAL=cabal + else + # Install the GHC we want from hvr's PPA + travis_retry sudo add-apt-repository -y ppa:hvr/ghc + travis_retry sudo apt-get update + travis_retry sudo apt-get install cabal-install-1.18 ghc-$GHCVER happy + export CABAL=cabal-1.18 + export PATH=/opt/ghc/$GHCVER/bin:$PATH + fi + # Uncomment whenever hackage is down. + # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && $CABAL update + - $CABAL update + + # Update happy when building with GHC head + - | + if [ $GHCVER = "head" ] || [ $GHCVER = "7.8.1" ]; then + $CABAL install happy alex + export PATH=$HOME/.cabal/bin:$PATH + fi + +install: + - $CABAL install --dependencies-only --enable-tests + - $CABAL configure --enable-tests $MODE + +script: + - $CABAL build + - $CABAL test --show-details=always + +notifications: + irc: + channels: + - "irc.freenode.org#haskell-lens" + skip_join: true + template: + - "\x0313search\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" diff --git a/.vim.custom b/.vim.custom new file mode 100644 --- /dev/null +++ b/.vim.custom @@ -0,0 +1,31 @@ +" Add the following to your .vimrc to automatically load this on startup + +" if filereadable(".vim.custom") +" so .vim.custom +" endif + +function StripTrailingWhitespace() + let myline=line(".") + let mycolumn = col(".") + silent %s/ *$// + call cursor(myline, mycolumn) +endfunction + +" enable syntax highlighting +syntax on + +" search for the tags file anywhere between here and / +set tags=TAGS;/ + +" highlight tabs and trailing spaces +set listchars=tab:‗‗,trail:‗ +set list + +" f2 runs hasktags +map :exec ":!hasktags -x -c --ignore src" + +" strip trailing whitespace before saving +" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() + +" rebuild hasktags after saving +au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -0,0 +1,3 @@ +0.1 +--- +* Repository initialized diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright 2014 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,16 @@ +search +====== + +[![Build Status](https://secure.travis-ci.org/ekmett/search.png?branch=master)](http://travis-ci.org/ekmett/search) + + +This package provides a version of Martin Escardo's "J" monad for conducting "infinite search in finite time". + +Contact Information +------------------- + +Contributions and bug reports are welcome! + +Please feel free to contact me through github or on the `#haskell` or `#haskell-lens` IRC channels on `irc.freenode.net`. + +-Edward Kmett diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,44 @@ +#!/usr/bin/runhaskell +\begin{code} +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +import Data.List ( nub ) +import Data.Version ( showVersion ) +import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) +import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) +import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) +import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) +import Distribution.Simple.BuildPaths ( autogenModulesDir ) +import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) +import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) +import Distribution.Verbosity ( Verbosity ) +import System.FilePath ( () ) + +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { buildHook = \pkg lbi hooks flags -> do + generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi + buildHook simpleUserHooks pkg lbi hooks flags + } + +generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () +generateBuildModule verbosity pkg lbi = do + let dir = autogenModulesDir lbi + createDirectoryIfMissingVerbose verbosity True dir + withLibLBI pkg lbi $ \_ libcfg -> do + withTestLBI pkg lbi $ \suite suitecfg -> do + rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines + [ "module Build_" ++ testName suite ++ " where" + , "deps :: [String]" + , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) + ] + where + formatdeps = map (formatone . snd) + formatone p = case packageName p of + PackageName n -> n ++ "-" ++ showVersion (packageVersion p) + +testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] +testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys + +\end{code} diff --git a/search.cabal b/search.cabal new file mode 100644 --- /dev/null +++ b/search.cabal @@ -0,0 +1,53 @@ +name: search +category: Math, Topology, Search +version: 0.1 +license: BSD3 +cabal-version: >= 1.8 +license-file: LICENSE +author: Edward A. Kmett +maintainer: Edward A. Kmett +stability: provisional +homepage: http://github.com/ekmett/search/ +bug-reports: http://github.com/ekmett/search/issues +copyright: Copyright (C) 2014 Edward A. Kmett +synopsis: Infinite search in finite time with Hilbert's epsilon +description: Infinite search in finite time with Hilbert's epsilon +build-type: Custom +extra-source-files: + .travis.yml + .vim.custom + travis/config + CHANGELOG.markdown + README.markdown + +source-repository head + type: git + location: git://github.com/ekmett/search.git + +library + build-depends: + base >= 4.5 && < 5, + ghc-prim, + profunctors >= 4 && < 5, + semigroupoids >= 4 && < 5, + tagged >= 0.7 && < 1, + transformers >= 0.3 && < 0.4 + + exposed-modules: + Data.Search + + ghc-options: -Wall -fwarn-tabs -O2 + hs-source-dirs: src + +-- Verify the results of the examples +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + ghc-options: -Wall -Werror -threaded + hs-source-dirs: tests + build-depends: + base, + directory >= 1.0 && < 1.3, + doctest >= 0.8 && < 0.10, + filepath >= 1.3 && < 1.4, + search diff --git a/src/Data/Search.hs b/src/Data/Search.hs new file mode 100644 --- /dev/null +++ b/src/Data/Search.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.Search + ( Search(..) + , pessimum + , optimalScore, pessimalScore + , cps + , union + , pair + , fromList + -- * Hilbert's epsilon + , Hilbert(..) + , best, worst + , bestScore, worstScore + -- * Boolean-valued search + , every + , exists + ) where + +import Control.Applicative +import Control.Monad.Trans.Cont +import Data.Function (on) +import Data.Functor.Alt +import Data.Functor.Bind +import Data.Int +import Data.Monoid +import Data.Ord +import Data.Profunctor +import Data.Proxy +import Data.Tagged +import Data.Typeable +import Data.Word +import GHC.Generics + +-- | Given a test that is required to execute in finite time for _all_ inputs, even infinite ones, +-- 'Search' should productively yield an answer. +-- +-- I currently also assume that comparison of scores can be done in finite time for all scores. +-- +-- This rules out large score sets. +-- +-- @'Search' 'Bool'@ can be used for predicate searches. +newtype Search a b = Search { optimum :: (b -> a) -> b } + deriving Typeable + +-- | Find the worst-scoring result of a search. +pessimum :: Search (Down a) b -> (b -> a) -> b +pessimum = optimum . lmap Down + +instance Profunctor Search where + dimap f g (Search k) = Search $ \ba -> g (k (f.ba.g)) + {-# INLINE dimap #-} + +instance Functor (Search a) where + fmap f (Search k) = Search $ \ba -> f (k (ba.f)) + {-# INLINE fmap #-} + +instance Apply (Search a) where + (<.>) = (<*>) + {-# INLINE (<.>) #-} + +instance Applicative (Search a) where + pure b = Search $ \_ -> b + fs <*> as = Search $ \p -> + let go q = q $ optimum as (p.q) + in go $ optimum fs (p.go) + +instance Ord a => Alt (Search a) where + l r = Search go where + go p + | p a >= p b = a + | otherwise = b + where + a = optimum l p + b = optimum r p + +instance Bind (Search a) where + Search ma >>- f = Search $ \p -> + optimum (f (ma (\a -> p (optimum (f a) p)))) p + +instance Monad (Search a) where + return a = Search $ \_ -> a + Search ma >>= f = Search $ \p -> + optimum (f (ma (\a -> p (optimum (f a) p)))) p + +-- | +class Hilbert a b where + epsilon :: Search a b + default epsilon :: (GHilbert a (Rep b), Generic b) => Search a b + epsilon = to <$> gepsilon + +-- | Generic derivation of Hilbert's epsilon. +class GHilbert a f where + gepsilon :: Search a (f b) + +instance GHilbert a U1 where + gepsilon = pure U1 + +instance (GHilbert a f, GHilbert a g) => GHilbert a (f :*: g) where + gepsilon = liftA2 (:*:) gepsilon gepsilon + +instance (GHilbert a f, GHilbert a g, Ord a) => GHilbert a (f :+: g) where + gepsilon = L1 <$> gepsilon R1 <$> gepsilon + +instance Hilbert a b => GHilbert a (K1 i b) where + gepsilon = K1 <$> epsilon + +instance GHilbert a f => GHilbert a (M1 i c f) where + gepsilon = M1 <$> gepsilon + +instance Hilbert x () +instance Hilbert x (Proxy a) where epsilon = pure Proxy +instance Hilbert x a => Hilbert x (Tagged s a) where epsilon = Tagged <$> epsilon +instance (Hilbert x a, Hilbert x b) => Hilbert x (a, b) +instance (Hilbert x a, Hilbert x b, Hilbert x c) => Hilbert x (a, b, c) +instance (Hilbert x a, Hilbert x b, Hilbert x c, Hilbert x d) => Hilbert x (a, b, c, d) +instance (Hilbert x a, Hilbert x b, Hilbert x c, Hilbert x d, Hilbert x e) => Hilbert x (a, b, c, d, e) +instance Ord x => Hilbert x Bool +instance Ord x => Hilbert x Any where epsilon = Any <$> epsilon +instance Ord x => Hilbert x All where epsilon = All <$> epsilon +instance Hilbert x a => Hilbert x (Product a) where epsilon = Product <$> epsilon +instance Hilbert x a => Hilbert x (Sum a) where epsilon = Sum <$> epsilon +instance Ord x => Hilbert x Ordering +instance Ord x => Hilbert x Char where epsilon = fromList [minBound .. maxBound] +instance Ord x => Hilbert x Int8 where epsilon = fromList [minBound .. maxBound] +instance Ord x => Hilbert x Int16 where epsilon = fromList [minBound .. maxBound] +instance Ord x => Hilbert x Word8 where epsilon = fromList [minBound .. maxBound] +instance Ord x => Hilbert x Word16 where epsilon = fromList [minBound .. maxBound] +instance (Ord x, Hilbert x a) => Hilbert x [a] +instance (Ord x, Hilbert x a) => Hilbert x (ZipList a) where epsilon = ZipList <$> epsilon +instance (Ord x, Hilbert x a) => Hilbert x (Maybe a) +instance (Ord x, Hilbert x a) => Hilbert x (First a) where epsilon = First <$> epsilon +instance (Ord x, Hilbert x a) => Hilbert x (Last a) where epsilon = Last <$> epsilon +instance (Ord x, Hilbert x a, Hilbert x b) => Hilbert x (Either a b) +instance (Ord x, Ord a, Hilbert x b) => Hilbert x (Search a b) where + epsilon = fromList <$> epsilon + +-- | What is the best score obtained by the search? +optimalScore :: Search a b -> (b -> a) -> a +optimalScore m p = p (optimum m p) + +-- | What is the worst score obtained by the search? +pessimalScore :: Search (Down a) b -> (b -> a) -> a +pessimalScore m p = p (pessimum m p) + +-- | search for an optimal answer using Hilbert's epsilon +-- +-- >>> search (>4) :: Int8 +-- 5 +best :: Hilbert a b => (b -> a) -> b +best = optimum epsilon + +-- | What is the worst scoring answer by Hilbert's epsilon? +worst :: Hilbert (Down a) b => (b -> a) -> b +worst = pessimum epsilon + +bestScore :: Hilbert a b => (b -> a) -> a +bestScore = optimalScore epsilon + +worstScore :: Hilbert (Down a) b => (b -> a) -> a +worstScore = pessimalScore epsilon + +-- | does there exist an element satisfying the predicate? +-- +-- >>> exists (>(maxBound::Int8)) +-- False +-- +exists :: Hilbert Bool b => (b -> Bool) -> Bool +exists = bestScore + +every :: Hilbert Bool b => (b -> Bool) -> Bool +every p = not.p $ best $ not.p + +union :: Ord a => Search a b -> Search a b -> Search a b +union = () + +pair :: Ord a => b -> b -> Search a b +pair = on () pure + +fromList :: Ord a => [b] -> Search a b +fromList = foldr1 () . map return + +-- | 'Search' is more powerful than 'Cont'. +-- +-- This provides a canonical monad homomorphism into 'Cont'. +cps :: Search a b -> Cont a b +cps = cont . optimalScore diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -0,0 +1,30 @@ +module Main where + +import Build_doctests (deps) +import Control.Applicative +import Control.Monad +import Data.List +import System.Directory +import System.FilePath +import Test.DocTest + +main :: IO () +main = getSources >>= \sources -> doctest $ + "-isrc" + : "-idist/build/autogen" + : "-optP-include" + : "-optPdist/build/autogen/cabal_macros.h" + : "-hide-all-packages" + : map ("-package="++) deps ++ sources + +getSources :: IO [FilePath] +getSources = filter (isSuffixOf ".hs") <$> go "src" + where + go dir = do + (dirs, files) <- getFilesAndDirectories dir + (files ++) . concat <$> mapM go dirs + +getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) +getFilesAndDirectories dir = do + c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir + (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c diff --git a/travis/config b/travis/config new file mode 100644 --- /dev/null +++ b/travis/config @@ -0,0 +1,16 @@ +-- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix +-- +-- This is particularly useful for travis-ci to get it to stop complaining +-- about a broken build when everything is still correct on our end. +-- +-- This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead +-- +-- To enable this, uncomment the before_script in .travis.yml + +remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive +remote-repo-cache: ~/.cabal/packages +world-file: ~/.cabal/world +build-summary: ~/.cabal/logs/build.log +remote-build-reporting: anonymous +install-dirs user +install-dirs global