From d7d87803bc694dfd0f4e494e1152ad7cad2d2d0e Mon Sep 17 00:00:00 2001 From: Patrik Jansson Date: Wed, 7 Dec 2016 00:16:17 +0100 Subject: [PATCH] A partial example program for SeqDecProbs in Haskell --- talks/2016-11_Oxford/.gitignore | 1 + talks/2016-11_Oxford/Example.hs | 68 ++++++++++++++++++++++++++ talks/2016-11_Oxford/LICENSE | 30 ++++++++++++ talks/2016-11_Oxford/SeqDecProbs.cabal | 24 +++++++++ talks/2016-11_Oxford/Setup.hs | 2 + talks/2016-11_Oxford/stack.yaml | 66 +++++++++++++++++++++++++ 6 files changed, 191 insertions(+) create mode 100644 talks/2016-11_Oxford/.gitignore create mode 100644 talks/2016-11_Oxford/Example.hs create mode 100644 talks/2016-11_Oxford/LICENSE create mode 100644 talks/2016-11_Oxford/SeqDecProbs.cabal create mode 100644 talks/2016-11_Oxford/Setup.hs create mode 100644 talks/2016-11_Oxford/stack.yaml diff --git a/talks/2016-11_Oxford/.gitignore b/talks/2016-11_Oxford/.gitignore new file mode 100644 index 0000000..3a5b475 --- /dev/null +++ b/talks/2016-11_Oxford/.gitignore @@ -0,0 +1 @@ +.stack-work/ diff --git a/talks/2016-11_Oxford/Example.hs b/talks/2016-11_Oxford/Example.hs new file mode 100644 index 0000000..9bed3b3 --- /dev/null +++ b/talks/2016-11_Oxford/Example.hs @@ -0,0 +1,68 @@ +module Example where +import Control.Monad (forM_) + +noOfStates = 6 + +newtype S = S Int deriving (Eq, Show) -- 0 .. noOfStates-1 +data C = L | A | R deriving (Eq, Enum, Show) +left, ahead, right :: S -> S +left (S i) = S $ (i-1) `mod` noOfStates +ahead = id +right (S i) = S $ (i+1) `mod` noOfStates + +type V = Int + +next :: S -> C -> S +next x L = left x +next x A = ahead x +next x R = right x + +reward :: S -> C -> S -> V +reward x c (S i') = (if i' == 0 then 2 else 0) -- reward for finding column zero + - (if c == A then 0 else 1) -- cost of moving + +val :: S -> [C] -> V +val x [] = 0 +val x (c:cs) = v + val x' cs + where x' = next x c + v = reward x c x' + +opt :: [C] -> [C] -> S -> Bool +opt cs = \cs' x -> val x cs' <= val x cs + +optExt :: [C] -> S -> C -- [C] -> C would not work - different states make different controls optimal +optExt [] (S 0) = A +optExt [] (S 1) = L +optExt [] (S i) | i == noOfStates-1 = R + | otherwise = A +optExt cs x = argMax (\c->val x (c:cs)) +-- Not correct + +argMax :: (C -> V) -> C +argMax rew = toEnum $ bestIndex $ map rew [L,A,R] + +bestIndex :: Ord v => [v] -> Int +bestIndex (v:vs) = go 0 0 v vs + where go i ibest best [] = ibest + go i ibest best (v:vs) + | v <= best = go (i+1) ibest best vs + | otherwise = go (i+1) i v vs + +showPolicy :: Show c => (S -> c) -> String +showPolicy p = show $ map (p.S) [0..noOfStates-1] + +test1 = optExt [] + +test2 = optExt [A] + +test3 css = mapM_ putStrLn $ map showPolicy $ map (\cs x -> (cs, val x cs)) css + +test31 = test3 allCtrls1 +test32 = test3 allCtrls2 + +lar = [L,A,R] +allCtrls1 = map (:[]) lar +allCtrls2 = crossWith (:) lar allCtrls1 + +crossWith :: (a->b->c) -> [a] -> [b] -> [c] +crossWith op xs ys = [op x y | y <- ys, x <- xs] diff --git a/talks/2016-11_Oxford/LICENSE b/talks/2016-11_Oxford/LICENSE new file mode 100644 index 0000000..a464c52 --- /dev/null +++ b/talks/2016-11_Oxford/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Patrik Jansson + +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. + + * Neither the name of Patrik Jansson nor the names of other + contributors may 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. diff --git a/talks/2016-11_Oxford/SeqDecProbs.cabal b/talks/2016-11_Oxford/SeqDecProbs.cabal new file mode 100644 index 0000000..bcb3881 --- /dev/null +++ b/talks/2016-11_Oxford/SeqDecProbs.cabal @@ -0,0 +1,24 @@ +-- Initial SeqDecProbs.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: SeqDecProbs +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD3 +license-file: LICENSE +author: Patrik Jansson +maintainer: patrik.ja@gmail.com +-- copyright: +-- category: +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Example + -- other-modules: + -- other-extensions: + build-depends: base >=4.9 && <4.10 + -- hs-source-dirs: + default-language: Haskell2010 \ No newline at end of file diff --git a/talks/2016-11_Oxford/Setup.hs b/talks/2016-11_Oxford/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/talks/2016-11_Oxford/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/talks/2016-11_Oxford/stack.yaml b/talks/2016-11_Oxford/stack.yaml new file mode 100644 index 0000000..ee1f8bf --- /dev/null +++ b/talks/2016-11_Oxford/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# http://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-7.12 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- '.' +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.2" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor \ No newline at end of file