Repository: edwinb/TypeDD-Samples Branch: master Commit: a5c08a13e6a6 Files: 164 Total size: 167.0 KB Directory structure: gitextract_49twblj_/ ├── Chapter1/ │ ├── Exercises/ │ │ └── ex_1_2.idr │ ├── FCTypes.idr │ ├── Hello.idr │ └── HelloHole.idr ├── Chapter10/ │ ├── DLFail.idr │ ├── DataStore.idr │ ├── DescribeList.idr │ ├── DescribeList2.idr │ ├── Exercises/ │ │ ├── DataStore.idr │ │ ├── ex_10_1.idr │ │ ├── ex_10_2.idr │ │ └── ex_10_3.idr │ ├── IsSuffix.idr │ ├── MergeSort.idr │ ├── MergeSortView.idr │ ├── Reverse.idr │ ├── ReverseSnoc.idr │ ├── Shape.idr │ ├── Shape_abs.idr │ ├── SnocList.idr │ └── TestStore.idr ├── Chapter11/ │ ├── Arith.idr │ ├── ArithCmd.idr │ ├── ArithCmdDo.idr │ ├── ArithTotal.idr │ ├── Exercises/ │ │ ├── ex_11_1.idr │ │ ├── ex_11_2.idr │ │ └── ex_11_3.idr │ ├── Greet.idr │ ├── InfIO.idr │ ├── InfList.idr │ ├── Label.idr │ ├── RunIO.idr │ ├── StreamFail.idr │ └── Streams.idr ├── Chapter12/ │ ├── ArithState.idr │ ├── DataStore.idr │ ├── Exercises/ │ │ ├── ex_12_1.idr │ │ ├── ex_12_3a.idr │ │ └── ex_12_3b.idr │ ├── Record.idr │ ├── State.idr │ ├── StateMonad.idr │ ├── Traverse.idr │ ├── TreeLabel.idr │ ├── TreeLabelState.idr │ └── TreeLabelType.idr ├── Chapter13/ │ ├── Door.idr │ ├── Exercises/ │ │ ├── ex_13_1.idr │ │ └── ex_13_2.idr │ ├── Stack.idr │ ├── StackIO.idr │ └── Vending.idr ├── Chapter14/ │ ├── ATM.idr │ ├── DoorJam.idr │ ├── Exercises/ │ │ ├── ex_14_2_1.idr │ │ └── ex_14_2_2.idr │ └── Hangman.idr ├── Chapter15/ │ ├── AdderChannel.idr │ ├── ListProc.idr │ ├── Process.idr │ ├── ProcessIFace.idr │ ├── ProcessLib.idr │ ├── ProcessLoop.idr │ ├── ProcessState.idr │ ├── WordCount.idr │ └── test.txt ├── Chapter2/ │ ├── AveMain.idr │ ├── Average.idr │ ├── Double.idr │ ├── Exercises/ │ │ ├── ex_2.ibc │ │ ├── ex_2.idr │ │ ├── ex_2_counts.ibc │ │ ├── ex_2_counts.idr │ │ ├── ex_2_palindrome.ibc │ │ └── ex_2_palindrome.idr │ ├── Generic.idr │ ├── HOF.idr │ ├── Let_Where.idr │ ├── Partial.idr │ └── Reverse.idr ├── Chapter3/ │ ├── Exercises/ │ │ ├── ex_3_2.ibc │ │ ├── ex_3_2.idr │ │ ├── ex_3_3.ibc │ │ └── ex_3_3.idr │ ├── IsEven.idr │ ├── Matrix.idr │ ├── VecSort.idr │ ├── Vectors.idr │ ├── WordLength.idr │ ├── WordLength_vec.idr │ └── XOR.idr ├── Chapter4/ │ ├── BSTree.idr │ ├── DataStore.idr │ ├── Direction.idr │ ├── Exercises/ │ │ ├── ex_4_1.idr │ │ ├── ex_4_2.idr │ │ ├── ex_4_2_1.idr │ │ ├── ex_4_2_2.idr │ │ ├── ex_4_2_3.idr │ │ ├── ex_4_2_5.idr │ │ └── ex_4_3.idr │ ├── Generic.idr │ ├── Picture.idr │ ├── Shape.idr │ ├── SumInputs.idr │ ├── Tree.idr │ ├── TryIndex.idr │ ├── Vect.idr │ └── Vehicle.idr ├── Chapter5/ │ ├── DepPairs.idr │ ├── Do.idr │ ├── Exercises/ │ │ ├── ex_5_1.idr │ │ ├── ex_5_2_1.idr │ │ ├── ex_5_2_3.idr │ │ ├── ex_5_2_4.idr │ │ └── ex_5_3.idr │ ├── Hello.idr │ ├── Loops.idr │ ├── PrintLength.idr │ ├── ReadNum.idr │ └── ReadVect.idr ├── Chapter6/ │ ├── Adder.idr │ ├── DataStore.idr │ ├── DataStoreHoles.idr │ ├── Exercises/ │ │ ├── ex_6_2_1.idr │ │ ├── ex_6_2_2.idr │ │ ├── ex_6_2_3.idr │ │ ├── ex_6_3_1.idr │ │ ├── ex_6_3_2.idr │ │ └── ex_6_3_3.idr │ ├── Maybe.idr │ ├── Printf.idr │ ├── TypeFuns.idr │ └── TypeSynonyms.idr ├── Chapter7/ │ ├── Album.idr │ ├── Eq.idr │ ├── Exercises/ │ │ ├── ex_7_1.idr │ │ ├── ex_7_2.idr │ │ ├── ex_7_3_1.idr │ │ └── ex_7_3_2.idr │ ├── Expr.idr │ ├── Fold.idr │ └── Tree.idr ├── Chapter8/ │ ├── AppendVec.idr │ ├── CheckEqDec.idr │ ├── CheckEqMaybe.idr │ ├── EqNat.idr │ ├── ExactLength.idr │ ├── ExactLengthDec.idr │ ├── Exercises/ │ │ ├── ex_8_1.idr │ │ ├── ex_8_2.idr │ │ └── ex_8_3.idr │ ├── ReverseVec.idr │ ├── TCVects.idr │ └── Void.idr ├── Chapter9/ │ ├── Elem.idr │ ├── ElemBool.idr │ ├── ElemType.idr │ ├── Exercises/ │ │ └── ex_9_1.idr │ ├── Hangman.idr │ └── RemoveElem.idr ├── LICENSE └── README.md ================================================ FILE CONTENTS ================================================ ================================================ FILE: Chapter1/Exercises/ex_1_2.idr ================================================ {- 1. Anything where the list is the same length as the input. We don't know the types of elements contained in the list, however, so we can't look at them. Some possibilities (there are many others!): - sorting the list - reversing the list - returning the input unchanged 2. Anything where the output list is twice as long as the input. Some possibilities: - Duplicating each element - Returning the list appended to itself 3. Anything where the output list is one item shorter than the input, which must itself be non-empty. Some possibilities: - Returning all but the first element - Returning all but the last element 4. The bounded number is likely to refer to a position in the list, so this could be a function to return the element at that position. -} ================================================ FILE: Chapter1/FCTypes.idr ================================================ StringOrInt : Bool -> Type StringOrInt x = case x of True => Int False => String getStringOrInt : (x : Bool) -> StringOrInt x getStringOrInt x = case x of True => 94 False => "Ninety four" valToString : (x : Bool) -> StringOrInt x -> String valToString x val = case x of True => cast val False => val ================================================ FILE: Chapter1/Hello.idr ================================================ module Main main : IO () main = putStrLn "Hello, Idris world!" ================================================ FILE: Chapter1/HelloHole.idr ================================================ module Main main : IO () main = putStrLn ?greeting ================================================ FILE: Chapter10/DLFail.idr ================================================ describe_list_end : List Int -> String describe_list_end [] = "Empty" describe_list_end (xs ++ [x]) = "Non-empty, initial portion = " ++ show xs ================================================ FILE: Chapter10/DataStore.idr ================================================ module DataStore import Data.Vect infixr 5 .+. public export data Schema = SString | SInt | (.+.) Schema Schema public export SchemaType : Schema -> Type SchemaType SString = String SchemaType SInt = Int SchemaType (x .+. y) = (SchemaType x, SchemaType y) export record DataStore (schema : Schema) where constructor MkData size : Nat items : Vect size (SchemaType schema) export empty : DataStore schema empty = MkData 0 [] export addToStore : (entry : SchemaType schema) -> (store : DataStore schema) -> DataStore schema addToStore entry (MkData _ items) = MkData _ (entry :: items) public export data StoreView : DataStore schema -> Type where SNil : StoreView empty SAdd : (rec : StoreView store) -> StoreView (addToStore entry store) storeViewHelp : (items : Vect size (SchemaType schema)) -> StoreView (MkData size items) storeViewHelp [] = SNil storeViewHelp (entry :: xs) = SAdd (storeViewHelp xs) export storeView : (store : DataStore schema) -> StoreView store storeView (MkData size items) = storeViewHelp items ================================================ FILE: Chapter10/DescribeList.idr ================================================ data ListLast : List a -> Type where Empty : ListLast [] NonEmpty : (xs : List a) -> (x : a) -> ListLast (xs ++ [x]) listLast : (xs : List a) -> ListLast xs listLast [] = Empty listLast (x :: xs) = case listLast xs of Empty => NonEmpty [] x NonEmpty xs y => NonEmpty (x :: xs) y describeHelper : (input : List Int) -> ListLast input -> String describeHelper [] Empty = "Empty" describeHelper (xs ++ [x]) (NonEmpty xs x) = "Non-empty, initial portion = " ++ show xs describeListEnd : List Int -> String describeListEnd xs = describeHelper xs (listLast xs) ================================================ FILE: Chapter10/DescribeList2.idr ================================================ data ListLast : List a -> Type where Empty : ListLast [] NonEmpty : (xs : List a) -> (x : a) -> ListLast (xs ++ [x]) listLast : (xs : List a) -> ListLast xs listLast [] = Empty listLast (x :: xs) = case listLast xs of Empty => NonEmpty [] x NonEmpty xs y => NonEmpty (x :: xs) y describe_list_end : List Int -> String describe_list_end input with (listLast input) describe_list_end [] | Empty = ?describe_list_end_rhs_1 describe_list_end (xs ++ [x]) | (NonEmpty xs x) = ?describe_list_end_rhs_2 ================================================ FILE: Chapter10/Exercises/DataStore.idr ================================================ module DataStore import Data.Vect infixr 5 .+. public export data Schema = SString | SInt | (.+.) Schema Schema public export SchemaType : Schema -> Type SchemaType SString = String SchemaType SInt = Int SchemaType (x .+. y) = (SchemaType x, SchemaType y) export record DataStore (schema : Schema) where constructor MkData size : Nat items : Vect size (SchemaType schema) export empty : DataStore schema empty = MkData 0 [] export addToStore : (entry : SchemaType schema) -> (store : DataStore schema) -> DataStore schema addToStore entry (MkData _ items) = MkData _ (entry :: items) public export data StoreView : DataStore schema -> Type where SNil : StoreView empty SAdd : (rec : StoreView store) -> StoreView (addToStore entry store) storeViewHelp : (items : Vect size (SchemaType schema)) -> StoreView (MkData size items) storeViewHelp [] = SNil storeViewHelp (entry :: xs) = SAdd (storeViewHelp xs) export storeView : (store : DataStore schema) -> StoreView store storeView (MkData size items) = storeViewHelp items ================================================ FILE: Chapter10/Exercises/ex_10_1.idr ================================================ {- 1 -} data TakeN : List a -> Type where Fewer : TakeN xs Exact : (n_xs : List a) -> TakeN (n_xs ++ rest) takeN : (n : Nat) -> (xs : List a) -> TakeN xs takeN Z xs = Exact [] takeN (S k) [] = Fewer takeN (S k) (x :: xs) with (takeN k xs) takeN (S k) (x :: xs) | Fewer = Fewer takeN (S k) (x :: (n_xs ++ rest)) | Exact _ = Exact (x :: n_xs) groupByN : (n : Nat) -> (xs : List a) -> List (List a) groupByN n xs with (takeN n xs) groupByN n xs | Fewer = [xs] groupByN n (n_xs ++ rest) | (Exact n_xs) = n_xs :: groupByN n rest {- 2 -} halves : List a -> (List a, List a) halves input with (takeN (length input `div` 2) input) halves input | Fewer = (input, []) halves (n_xs ++ rest) | (Exact n_xs) = (n_xs, rest) ================================================ FILE: Chapter10/Exercises/ex_10_2.idr ================================================ import Data.Vect import Data.List.Views import Data.Vect.Views import Data.Nat.Views {- 1 -} total equalSuffix : Eq a => List a -> List a -> List a equalSuffix input1 input2 with (snocList input1) equalSuffix [] input2 | Empty = [] equalSuffix (xs ++ [x]) input2 | (Snoc xsrec) with (snocList input2) equalSuffix (xs ++ [x]) [] | (Snoc xsrec) | Empty = [] equalSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc xsrec) | (Snoc ysrec) = if x == y then equalSuffix xs ys | xsrec | ysrec ++ [y] else [] {- 2 -} total mergeSort : Ord a => Vect n a -> Vect n a mergeSort xs with (splitRec xs) mergeSort [] | SplitRecNil = [] mergeSort [x] | SplitRecOne = [x] mergeSort (ys ++ zs) | (SplitRecPair lrec rrec) = merge (mergeSort ys | lrec) (mergeSort zs | rrec) {- 3 -} total toBinary : Nat -> String toBinary k with (halfRec k) toBinary Z | HalfRecZ = "" toBinary (n + n) | (HalfRecEven rec) = toBinary n | rec ++ "0" toBinary (S (n + n)) | (HalfRecOdd rec) = toBinary n | rec ++ "1" {- 4 -} palindrome : Eq a => List a -> Bool palindrome input with (vList input) palindrome [] | VNil = True palindrome [x] | VOne = True palindrome (x :: (xs ++ [y])) | (VCons rec) = x == y && palindrome xs ================================================ FILE: Chapter10/Exercises/ex_10_3.idr ================================================ import DataStore import Data.Vect {- 1 -} testStore : DataStore (SString .+. SInt) testStore = addToStore ("First", 1) $ addToStore ("Second", 2) $ empty getValues : DataStore (SString .+. val_schema) -> List (SchemaType val_schema) getValues input with (storeView input) getValues empty | SNil = [] getValues (addToStore (key, value) store) | (SAdd rec) = value :: getValues store | rec {- 2 -} export data Shape = Triangle Double Double | Rectangle Double Double | Circle Double export triangle : Double -> Double -> Shape triangle = Triangle export rectangle : Double -> Double -> Shape rectangle = Rectangle export circle : Double -> Shape circle = Circle data ShapeView : Shape -> Type where STriangle : ShapeView (triangle base height) SRectangle : ShapeView (rectangle width height) SCircle : ShapeView (circle radius) shapeView : (s : Shape) -> ShapeView s shapeView (Triangle x y) = STriangle shapeView (Rectangle x y) = SRectangle shapeView (Circle x) = SCircle area : Shape -> Double area s with (shapeView s) area (triangle base height) | STriangle = 0.5 * base * height area (rectangle width height) | SRectangle = width * height area (circle radius) | SCircle = pi * radius * radius ================================================ FILE: Chapter10/IsSuffix.idr ================================================ import Data.List.Views total isSuffix : Eq a => List a -> List a -> Bool isSuffix input1 input2 with (snocList input1) isSuffix [] input2 | Empty = False isSuffix (xs ++ [x]) input2 | (Snoc xsrec) with (snocList input2) isSuffix (xs ++ [x]) [] | (Snoc xsrec) | Empty = False isSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc xsrec) | (Snoc ysrec) = if x == y then isSuffix xs ys | xsrec | ysrec else False ================================================ FILE: Chapter10/MergeSort.idr ================================================ import Debug.Trace data SplitList : List a -> Type where SplitNil : SplitList [] SplitOne : SplitList [x] SplitPair : (lefts : List a) -> (rights : List a) -> SplitList (lefts ++ rights) total splitList : (xs : List a) -> SplitList xs splitList xs = splitListHelp xs xs where splitListHelp : (counter : List a) -> (xs : List a) -> SplitList xs splitListHelp _ [] = SplitNil splitListHelp _ [x] = SplitOne splitListHelp (_ :: _ :: ys) (x :: xs) = case splitListHelp ys xs of SplitNil => SplitOne SplitOne {x=y} => SplitPair [x] [y] SplitPair lefts rights => SplitPair (x :: lefts) rights splitListHelp _ xs = SplitPair [] xs mergeSort : Ord a => List a -> List a mergeSort input with (splitList input) mergeSort [] | SplitNil = [] mergeSort [x] | SplitOne = [x] mergeSort (lefts ++ rights) | (SplitPair lefts rights) = merge (mergeSort lefts) (mergeSort rights) ================================================ FILE: Chapter10/MergeSortView.idr ================================================ import Data.List.Views mergeSort : Ord a => List a -> List a mergeSort input with (splitRec input) mergeSort [] | SplitRecNil = [] mergeSort [x] | SplitRecOne = [x] mergeSort (lefts ++ rights) | (SplitRecPair lrec rrec) = merge (mergeSort lefts | lrec) (mergeSort rights | rrec) ================================================ FILE: Chapter10/Reverse.idr ================================================ data ListLast : List a -> Type where Empty : ListLast [] NonEmpty : (xs : List a) -> (x : a) -> ListLast (xs ++ [x]) listLast : (xs : List a) -> ListLast xs listLast [] = Empty listLast (x :: xs) = case listLast xs of Empty => NonEmpty [] x NonEmpty xs y => NonEmpty (x :: xs) y myReverse : List a -> List a myReverse input with (listLast input) myReverse [] | Empty = [] myReverse (xs ++ [x]) | (NonEmpty xs x) = x :: myReverse xs ================================================ FILE: Chapter10/ReverseSnoc.idr ================================================ data SnocList ty = Empty | Snoc (SnocList ty) ty reverseSnoc : SnocList ty -> List ty reverseSnoc Empty = [] reverseSnoc (Snoc xs x) = x :: reverseSnoc xs ================================================ FILE: Chapter10/Shape.idr ================================================ module Shape public export data Shape = Triangle Double Double | Rectangle Double Double | Circle Double private rectangle_area : Double -> Double -> Double rectangle_area width height = width * height export area : Shape -> Double area (Triangle base height) = 0.5 * rectangle_area base height area (Rectangle length height) = rectangle_area length height area (Circle radius) = pi * radius * radius ================================================ FILE: Chapter10/Shape_abs.idr ================================================ module Shape_abs export data Shape = Triangle Double Double | Rectangle Double Double | Circle Double export triangle : Double -> Double -> Shape triangle = Triangle export rectangle : Double -> Double -> Shape rectangle = Rectangle export circle : Double -> Shape circle = Circle private rectangle_area : Double -> Double -> Double rectangle_area width height = width * height export area : Shape -> Double area (Triangle base height) = 0.5 * rectangle_area base height area (Rectangle length height) = rectangle_area length height area (Circle radius) = pi * radius * radius ================================================ FILE: Chapter10/SnocList.idr ================================================ data SnocList : List a -> Type where Empty : SnocList [] Snoc : (rec : SnocList xs) -> SnocList (xs ++ [x]) snocListHelp : (snoc : SnocList input) -> (rest : List a) -> SnocList (input ++ rest) snocListHelp {input} snoc [] = rewrite appendNilRightNeutral input in snoc snocListHelp {input} snoc (x :: xs) = rewrite appendAssociative input [x] xs in snocListHelp (Snoc snoc) xs snocList : (xs : List a) -> SnocList xs snocList xs = snocListHelp Empty xs my_reverse_help : (input : List a) -> SnocList input -> List a my_reverse_help [] Empty = [] my_reverse_help (xs ++ [x]) (Snoc rec) = x :: my_reverse_help xs rec my_reverse1 : List a -> List a my_reverse1 input = my_reverse_help input (snocList input) my_reverse : List a -> List a my_reverse input with (snocList input) my_reverse [] | Empty = [] my_reverse (xs ++ [x]) | (Snoc rec) = x :: my_reverse xs | rec ================================================ FILE: Chapter10/TestStore.idr ================================================ import DataStore testStore : DataStore (SString .+. SString .+. SInt) testStore = addToStore ("Mercury", "Mariner 10", 1974) $ addToStore ("Venus", "Venera", 1961) $ addToStore ("Uranus", "Voyager 2", 1986) $ addToStore ("Pluto", "New Horizons", 2015) $ empty listItems : DataStore schema -> List (SchemaType schema) listItems input with (storeView input) listItems empty | SNil = [] listItems (addToStore entry store) | (SAdd rec) = entry :: listItems store | rec filterKeys : (test : SchemaType val_schema -> Bool) -> DataStore (SString .+. val_schema) -> List String filterKeys test input with (storeView input) filterKeys test input | SNil = [] filterKeys test (addToStore (key, value) store) | (SAdd rec) = if test value then key :: filterKeys test store | rec else filterKeys test store | rec ================================================ FILE: Chapter11/Arith.idr ================================================ import Data.Primitives.Views import System quiz : Stream Int -> (score : Nat) -> IO () quiz (num1 :: num2 :: nums) score = do putStrLn ("Score so far: " ++ show score) putStr (show num1 ++ " * " ++ show num2 ++ "? ") answer <- getLine if cast answer == num1 * num2 then do putStrLn "Correct!" quiz nums (score + 1) else do putStrLn ("Wrong, the answer is " ++ show (num1 * num2)) quiz nums score randoms : Int -> Stream Int randoms seed = let seed' = 1664525 * seed + 1013904223 in (seed' `shiftR` 2) :: randoms seed' arithInputs : Int -> Stream Int arithInputs seed = map bound (randoms seed) where bound : Int -> Int bound x with (divides x 12) bound ((12 * div) + rem) | (DivBy prf) = rem + 1 main : IO () main = do seed <- time quiz (arithInputs (fromInteger seed)) 0 ================================================ FILE: Chapter11/ArithCmd.idr ================================================ import Data.Primitives.Views import System %default total data Command : Type -> Type where PutStr : String -> Command () GetLine : Command String data ConsoleIO : Type -> Type where Quit : a -> ConsoleIO a Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b (>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b (>>=) = Do data Fuel = Dry | More (Lazy Fuel) runCommand : Command a -> IO a runCommand (PutStr x) = putStr x runCommand GetLine = getLine run : Fuel -> ConsoleIO a -> IO (Maybe a) run fuel (Quit val) = do pure (Just val) run (More fuel) (Do c f) = do res <- runCommand c run fuel (f res) run Dry p = pure Nothing randoms : Int -> Stream Int randoms seed = let seed' = 1664525 * seed + 1013904223 in (seed' `shiftR` 2) :: randoms seed' arithInputs : Int -> Stream Int arithInputs seed = map bound (randoms seed) where bound : Int -> Int bound x with (divides x 12) bound ((12 * div) + rem) | (DivBy prf) = abs rem + 1 mutual correct : Stream Int -> (score : Nat) -> ConsoleIO Nat correct nums score = do PutStr "Correct!\n" quiz nums (score + 1) wrong : Stream Int -> Int -> (score : Nat) -> ConsoleIO Nat wrong nums ans score = do PutStr ("Wrong, the answer is " ++ show ans ++ "\n") quiz nums score quiz : Stream Int -> (score : Nat) -> ConsoleIO Nat quiz (num1 :: num2 :: nums) score = do PutStr ("Score so far: " ++ show score ++ "\n") PutStr (show num1 ++ " * " ++ show num2 ++ "? ") answer <- GetLine if toLower answer == "quit" then Quit score else if (cast answer == num1 * num2) then correct nums score else wrong nums (num1 * num2) score partial forever : Fuel forever = More forever partial main : IO () main = do seed <- time Just score <- run forever (quiz (arithInputs (fromInteger seed)) 0) | Nothing => putStrLn "Ran out of fuel" putStrLn ("Final score: " ++ show score) ================================================ FILE: Chapter11/ArithCmdDo.idr ================================================ import Data.Primitives.Views import System %default total data Command : Type -> Type where PutStr : String -> Command () GetLine : Command String Pure : ty -> Command ty Bind : Command a -> (a -> Command b) -> Command b data ConsoleIO : Type -> Type where Quit : a -> ConsoleIO a Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b namespace CommandDo (>>=) : Command a -> (a -> Command b) -> Command b (>>=) = Bind namespace ConsoleDo (>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b (>>=) = Do data Fuel = Dry | More (Lazy Fuel) runCommand : Command a -> IO a runCommand (PutStr x) = putStr x runCommand GetLine = getLine runCommand (Pure val) = pure val runCommand (Bind c f) = do res <- runCommand c runCommand (f res) run : Fuel -> ConsoleIO a -> IO (Maybe a) run fuel (Quit val) = do pure (Just val) run (More fuel) (Do c f) = do res <- runCommand c run fuel (f res) run Dry p = pure Nothing randoms : Int -> Stream Int randoms seed = let seed' = 1664525 * seed + 1013904223 in (seed' `shiftR` 2) :: randoms seed' arithInputs : Int -> Stream Int arithInputs seed = map bound (randoms seed) where bound : Int -> Int bound x with (divides x 12) bound ((12 * div) + rem) | (DivBy prf) = abs rem + 1 mutual correct : Stream Int -> (score : Nat) -> ConsoleIO Nat correct nums score = do PutStr "Correct!\n" quiz nums (score + 1) wrong : Stream Int -> Int -> (score : Nat) -> ConsoleIO Nat wrong nums ans score = do PutStr ("Wrong, the answer is " ++ show ans ++ "\n") quiz nums score data Input = Answer Int | QuitCmd readInput : (prompt : String) -> Command Input readInput prompt = do PutStr prompt answer <- GetLine if toLower answer == "quit" then Pure QuitCmd else Pure (Answer (cast answer)) quiz : Stream Int -> (score : Nat) -> ConsoleIO Nat quiz (num1 :: num2 :: nums) score = do PutStr ("Score so far: " ++ show score ++ "\n") input <- readInput (show num1 ++ " * " ++ show num2 ++ "? ") case input of Answer answer => if answer == num1 * num2 then correct nums score else wrong nums (num1 * num2) score QuitCmd => Quit score partial forever : Fuel forever = More forever partial main : IO () main = do seed <- time Just score <- run forever (quiz (arithInputs (fromInteger seed)) 0) | Nothing => putStrLn "Ran out of fuel" putStrLn ("Final score: " ++ show score) ================================================ FILE: Chapter11/ArithTotal.idr ================================================ import Data.Primitives.Views import System %default total data InfIO : Type where Do : IO a -> (a -> Inf InfIO) -> InfIO (>>=) : IO a -> (a -> Inf InfIO) -> InfIO (>>=) = Do data Fuel = Dry | More (Lazy Fuel) run : Fuel -> InfIO -> IO () run (More fuel) (Do c f) = do res <- c run fuel (f res) run Dry p = putStrLn "Out of fuel" randoms : Int -> Stream Int randoms seed = let seed' = 1664525 * seed + 1013904223 in (seed' `shiftR` 2) :: randoms seed' arithInputs : Int -> Stream Int arithInputs seed = map bound (randoms seed) where bound : Int -> Int bound x with (divides x 12) bound ((12 * div) + rem) | (DivBy prf) = abs rem + 1 quiz : Stream Int -> (score : Nat) -> InfIO quiz (num1 :: num2 :: nums) score = do putStrLn ("Score so far: " ++ show score) putStr (show num1 ++ " * " ++ show num2 ++ "? ") answer <- getLine if (cast answer == num1 * num2) then do putStrLn "Correct!" quiz nums (score + 1) else do putStrLn ("Wrong, the answer is " ++ show (num1 * num2)) quiz nums score partial forever : Fuel forever = More forever partial main : IO () main = do seed <- time run forever (quiz (arithInputs (fromInteger seed)) 0) ================================================ FILE: Chapter11/Exercises/ex_11_1.idr ================================================ import Data.Primitives.Views {- 1 -} every_other : Stream a -> Stream a every_other (x :: y :: xs) = y :: every_other xs {- 2 -} data InfList : Type -> Type where (::) : (value : elem) -> Inf (InfList elem) -> InfList elem %name InfList xs, ys, zs countFrom : Integer -> InfList Integer countFrom x = x :: Delay (countFrom (x + 1)) getPrefix : (count : Nat) -> InfList a -> List a getPrefix Z xs = [] getPrefix (S k) (value :: xs) = value :: getPrefix k xs Functor InfList where map func (value :: xs) = func value :: map func xs {- 3 -} randoms : Int -> Stream Int randoms seed = let seed' = 1664525 * seed + 1013904223 in (seed' `shiftR` 2) :: randoms seed' data Face = Heads | Tails total getFace : Int -> Face getFace x with (divides x 2) getFace ((2 * div) + rem) | (DivBy prf) = case rem of 0 => Heads _ => Tails coinFlips : Nat -> Stream Int -> List Face coinFlips k rnds = map getFace (take k rnds) {- 4 -} square_root_approx : (number : Double) -> (approx : Double) -> Stream Double square_root_approx number approx = let next = (approx + (number / approx)) / 2 in approx :: square_root_approx number next {- 5 -} square_root_bound : (max : Nat) -> (number : Double) -> (bound : Double) -> (approxs : Stream Double) -> Double square_root_bound Z number bound (x :: xs) = x square_root_bound (S k) number bound (x :: xs) = if (abs (x * x - number) < bound) then x else square_root_bound k number bound xs square_root : (number : Double) -> Double square_root number = square_root_bound 100 number 0.00000000001 (square_root_approx number number) ================================================ FILE: Chapter11/Exercises/ex_11_2.idr ================================================ {- Preamble, solution below -} import Data.Primitives.Views import System %default total data InfIO : Type where Do : IO a -> (a -> Inf InfIO) -> InfIO (>>=) : IO a -> (a -> Inf InfIO) -> InfIO (>>=) = Do data Fuel = Dry | More (Lazy Fuel) run : Fuel -> InfIO -> IO () run (More fuel) (Do c f) = do res <- c run fuel (f res) run Dry p = putStrLn "Out of fuel" randoms : Int -> Stream Int randoms seed = let seed' = 1664525 * seed + 1013904223 in (seed' `shiftR` 2) :: randoms seed' arithInputs : Int -> Stream Int arithInputs seed = map bound (randoms seed) where bound : Int -> Int bound x with (divides x 12) bound ((12 * div) + rem) | (DivBy prf) = abs rem + 1 partial forever : Fuel forever = More forever {- Solution -} totalREPL : (prompt : String) -> (action : String -> String) -> InfIO totalREPL prompt action = do putStr prompt inp <- getLine putStr (action inp) totalREPL prompt action ================================================ FILE: Chapter11/Exercises/ex_11_3.idr ================================================ import Data.Primitives.Views import System %default total data Command : Type -> Type where PutStr : String -> Command () GetLine : Command String data ConsoleIO : Type -> Type where Quit : a -> ConsoleIO a Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b (>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b (>>=) = Do data Fuel = Dry | More (Lazy Fuel) runCommand : Command a -> IO a runCommand (PutStr x) = putStr x runCommand GetLine = getLine run : Fuel -> ConsoleIO a -> IO (Maybe a) run fuel (Quit val) = do pure (Just val) run (More fuel) (Do c f) = do res <- runCommand c run fuel (f res) run Dry p = pure Nothing randoms : Int -> Stream Int randoms seed = let seed' = 1664525 * seed + 1013904223 in (seed' `shiftR` 2) :: randoms seed' arithInputs : Int -> Stream Int arithInputs seed = map bound (randoms seed) where bound : Int -> Int bound x with (divides x 12) bound ((12 * div) + rem) | (DivBy prf) = abs rem + 1 quiz : Stream Int -> (score : Nat) -> (questions : Nat) -> ConsoleIO (Nat, Nat) quiz (num1 :: num2 :: nums) score questions = do PutStr ("Score so far: " ++ show score ++ " / " ++ show questions ++ "\n") PutStr (show num1 ++ " * " ++ show num2 ++ "? ") answer <- GetLine if toLower answer == "quit" then Quit (score, questions) else if (cast answer == num1 * num2) then do PutStr "Correct!\n" quiz nums (score + 1) (questions + 1) else do PutStr ("Wrong, the answer is " ++ show (num1 * num2) ++ "\n") quiz nums score (questions + 1) partial forever : Fuel forever = More forever partial main : IO () main = do seed <- time Just (score, qs) <- run forever (quiz (arithInputs (fromInteger seed)) 0 0) | Nothing => putStrLn "Ran out of fuel" putStrLn ("Final score: " ++ show score ++ " / " ++ show qs) ================================================ FILE: Chapter11/Greet.idr ================================================ %default total data InfIO : Type where Do : IO a -> (a -> Inf InfIO) -> InfIO (>>=) : IO a -> (a -> Inf InfIO) -> InfIO (>>=) = Do greet : InfIO greet = do putStr "Enter your name: " name <- getLine putStrLn ("Hello " ++ name) greet ================================================ FILE: Chapter11/InfIO.idr ================================================ %default total data InfIO : Type where Do : IO a -> (a -> Inf InfIO) -> InfIO (>>=) : IO a -> (a -> Inf InfIO) -> InfIO (>>=) = Do loopPrint : String -> InfIO loopPrint msg = do putStrLn msg loopPrint msg data Fuel = Dry | More (Lazy Fuel) tank : Nat -> Fuel tank Z = Dry tank (S k) = More (tank k) partial runPartial : InfIO -> IO () runPartial (Do action f) = do res <- action runPartial (f res) run : Fuel -> InfIO -> IO () run (More fuel) (Do c f) = do res <- c run fuel (f res) run Dry p = putStrLn "Out of fuel" partial forever : Fuel forever = More forever partial main : IO () main = run (tank 10) (loopPrint "vroom") ================================================ FILE: Chapter11/InfList.idr ================================================ data InfList : Type -> Type where (::) : (value : elem) -> Inf (InfList elem) -> InfList elem %name InfList xs, ys, zs countFrom : Integer -> InfList Integer countFrom x = x :: Delay (countFrom (x + 1)) getPrefix : (count : Nat) -> InfList a -> List a getPrefix Z xs = [] getPrefix (S k) (value :: xs) = value :: getPrefix k xs labelWith : InfList Integer -> List a -> List (Integer, a) labelWith (lbl :: lbls) [] = [] labelWith (lbl :: lbls) (val :: vals) = (lbl, val) :: labelWith lbls vals label : List a -> List (Integer, a) label = labelWith (countFrom 0) ================================================ FILE: Chapter11/Label.idr ================================================ labelFrom : Integer -> List a -> List (Integer, a) labelFrom lbl [] = [] labelFrom lbl (val :: vals) = (lbl, val) :: labelFrom (lbl + 1) vals label : List a -> List (Integer, a) label = labelFrom 0 ================================================ FILE: Chapter11/RunIO.idr ================================================ %default total data RunIO : Type -> Type where Quit : a -> RunIO a Do : IO a -> (a -> Inf (RunIO b)) -> RunIO b (>>=) : IO a -> (a -> Inf (RunIO b)) -> RunIO b (>>=) = Do greet : RunIO () greet = do putStr "Enter your name: " name <- getLine if name == "" then do putStrLn "Bye bye!" Quit () else do putStrLn ("Hello " ++ name) greet data Fuel = Dry | More (Lazy Fuel) run : Fuel -> RunIO a -> IO (Maybe a) run fuel (Quit val) = do pure (Just val) run (More fuel) (Do c f) = do res <- c run fuel (f res) run Dry p = pure Nothing partial forever : Fuel forever = More forever partial main : IO () main = do run forever greet pure () ================================================ FILE: Chapter11/StreamFail.idr ================================================ countFrom : Integer -> List Integer countFrom n = n :: countFrom (n + 1) labelWith : List Integer -> List a -> List (Integer, a) labelWith lbls [] = [] labelWith (lbl :: lbls) (val :: vals) = (lbl, val) :: labelWith lbls vals ================================================ FILE: Chapter11/Streams.idr ================================================ labelWith : Stream labelType -> List a -> List (labelType, a) labelWith lbls [] = [] labelWith (lbl :: lbls) (val :: vals) = (lbl, val) :: labelWith lbls vals label : List a -> List (Integer, a) label vals = labelWith (iterate (+1) 0) vals ================================================ FILE: Chapter12/ArithState.idr ================================================ import Data.Primitives.Views import System %default total record Score where constructor MkScore correct : Nat attempted : Nat record GameState where constructor MkGameState score : Score difficulty : Int Show GameState where show st = show (correct (score st)) ++ "/" ++ show (attempted (score st)) ++ "\n" ++ "Difficulty: " ++ show (difficulty st) initState : GameState initState = MkGameState (MkScore 0 0) 12 addWrong : GameState -> GameState addWrong = record { score->attempted $= (+1) } addCorrect : GameState -> GameState addCorrect = record { score->correct $= (+1), score->attempted $= (+1) } setDifficulty : Int -> GameState -> GameState setDifficulty newDiff state = record { difficulty = newDiff } state data Command : Type -> Type where PutStr : String -> Command () GetLine : Command String GetRandom : Command Int GetGameState : Command GameState PutGameState : GameState -> Command () Pure : ty -> Command ty Bind : Command a -> (a -> Command b) -> Command b data ConsoleIO : Type -> Type where Quit : a -> ConsoleIO a Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b namespace ConsoleDo (>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b (>>=) = Do namespace CommandDo (>>=) : Command a -> (a -> Command b) -> Command b (>>=) = Bind randoms : Int -> Stream Int randoms seed = let seed' = 1664525 * seed + 1013904223 in (seed' `shiftR` 2) :: randoms seed' runCommand : Stream Int -> GameState -> Command a -> IO (a, Stream Int, GameState) runCommand rnds state (PutStr x) = do putStr x pure ((), rnds, state) runCommand rnds state GetLine = do str <- getLine pure (str, rnds, state) runCommand (val :: rnds) state GetRandom = pure (getRandom val (difficulty state), rnds, state) where getRandom : Int -> Int -> Int getRandom val max with (divides val max) getRandom val 0 | DivByZero = 1 getRandom ((max * div) + rem) max | (DivBy prf) = abs rem + 1 runCommand rnds state GetGameState = pure (state, rnds, state) runCommand rnds state (PutGameState newState) = pure ((), rnds, newState) runCommand rnds state (Pure val) = pure (val, rnds, state) runCommand rnds state (Bind c f) = do (res, newRnds, newState) <- runCommand rnds state c runCommand newRnds newState (f res) data Fuel = Dry | More (Lazy Fuel) partial forever : Fuel forever = More forever run : Fuel -> Stream Int -> GameState -> ConsoleIO a -> IO (Maybe a, Stream Int, GameState) run fuel rnds state (Quit val) = do pure (Just val, rnds, state) run (More fuel) rnds state (Do c f) = do (res, newRnds, newState) <- runCommand rnds state c run fuel newRnds newState (f res) run Dry rnds state p = pure (Nothing, rnds, state) mutual correct : ConsoleIO GameState correct = do PutStr "Correct!\n" st <- GetGameState PutGameState (addCorrect st) quiz wrong : Int -> ConsoleIO GameState wrong ans = do PutStr ("Wrong, the answer is " ++ show ans ++ "\n") st <- GetGameState PutGameState (addWrong st) quiz data Input = Answer Int | QuitCmd readInput : (prompt : String) -> Command Input readInput prompt = do PutStr prompt answer <- GetLine if toLower answer == "quit" then Pure QuitCmd else Pure (Answer (cast answer)) quiz : ConsoleIO GameState quiz = do num1 <- GetRandom num2 <- GetRandom st <- GetGameState PutStr (show st ++ "\n") input <- readInput (show num1 ++ " * " ++ show num2 ++ "? ") case input of Answer answer => if answer == num1 * num2 then correct else wrong (num1 * num2) QuitCmd => Quit st partial main : IO () main = do seed <- time (Just score, _, state) <- run forever (randoms (fromInteger seed)) initState quiz | _ => putStrLn "Ran out of fuel" putStrLn ("Final score: " ++ show state) ================================================ FILE: Chapter12/DataStore.idr ================================================ module Main import Data.Vect infixr 5 .+. data Schema = SString | SInt | (.+.) Schema Schema SchemaType : Schema -> Type SchemaType SString = String SchemaType SInt = Int SchemaType (x .+. y) = (SchemaType x, SchemaType y) record DataStore (size : Nat) where constructor MkData schema : Schema items : Vect size (SchemaType schema) setSchema : DataStore 0 -> Schema -> DataStore 0 setSchema (MkData schema []) schema' = MkData schema' [] data Command : Schema -> Type where SetSchema : Schema -> Command schema Add : SchemaType schema -> Command schema Get : Integer -> Command schema Quit : Command schema ================================================ FILE: Chapter12/Exercises/ex_12_1.idr ================================================ import Control.Monad.State data Tree a = Empty | Node (Tree a) a (Tree a) testTree : Tree String testTree = Node (Node (Node Empty "Jim" Empty) "Fred" (Node Empty "Sheila" Empty)) "Alice" (Node Empty "Bob" (Node Empty "Eve" Empty)) {- 1 -} update : (stateType -> stateType) -> State stateType () update f = do st <- get put (f st) increment : Nat -> State Nat () increment x = update (+x) {- 2 -} countEmpty : Tree a -> State Nat () countEmpty Empty = update (+1) countEmpty (Node left val right) = do countEmpty left countEmpty right {- 3 -} countEmptyNode : Tree a -> State (Nat, Nat) () countEmptyNode Empty = do (empty, nodes) <- get put (empty + 1, nodes) countEmptyNode (Node left val right) = do countEmptyNode left (empty, nodes) <- get put (empty, nodes + 1) countEmptyNode right ================================================ FILE: Chapter12/Exercises/ex_12_3a.idr ================================================ import Data.Primitives.Views import System %default total record Score where constructor MkScore correct : Nat attempted : Nat record GameState where constructor MkGameState score : Score difficulty : Int Show GameState where show st = show (correct (score st)) ++ "/" ++ show (attempted (score st)) ++ "\n" ++ "Difficulty: " ++ show (difficulty st) initState : GameState initState = MkGameState (MkScore 0 0) 12 addWrong : GameState -> GameState addWrong = record { score->attempted $= (+1) } addCorrect : GameState -> GameState addCorrect = record { score->correct $= (+1), score->attempted $= (+1) } setDifficulty : Int -> GameState -> GameState setDifficulty newDiff state = record { difficulty = newDiff } state data Command : Type -> Type where PutStr : String -> Command () GetLine : Command String GetRandom : Command Int GetGameState : Command GameState PutGameState : GameState -> Command () Pure : ty -> Command ty Bind : Command a -> (a -> Command b) -> Command b data ConsoleIO : Type -> Type where Quit : a -> ConsoleIO a Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b namespace ConsoleDo (>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b (>>=) = Do {- 2 -} mutual Functor Command where map func x = do x' <- x pure (func x') Applicative Command where pure = Pure (<*>) f a = do f' <- f a' <- a pure (f' a') Monad Command where (>>=) = Bind randoms : Int -> Stream Int randoms seed = let seed' = 1664525 * seed + 1013904223 in (seed' `shiftR` 2) :: randoms seed' runCommand : Stream Int -> GameState -> Command a -> IO (a, Stream Int, GameState) runCommand rnds state (PutStr x) = do putStr x pure ((), rnds, state) runCommand rnds state GetLine = do str <- getLine pure (str, rnds, state) runCommand (val :: rnds) state GetRandom = pure (getRandom val (difficulty state), rnds, state) where getRandom : Int -> Int -> Int getRandom val max with (divides val max) getRandom val 0 | DivByZero = 1 getRandom ((max * div) + rem) max | (DivBy prf) = abs rem + 1 runCommand rnds state GetGameState = pure (state, rnds, state) runCommand rnds state (PutGameState newState) = pure ((), rnds, newState) runCommand rnds state (Pure val) = pure (val, rnds, state) runCommand rnds state (Bind c f) = do (res, newRnds, newState) <- runCommand rnds state c runCommand newRnds newState (f res) data Fuel = Dry | More (Lazy Fuel) partial forever : Fuel forever = More forever run : Fuel -> Stream Int -> GameState -> ConsoleIO a -> IO (Maybe a, Stream Int, GameState) run fuel rnds state (Quit val) = do pure (Just val, rnds, state) run (More fuel) rnds state (Do c f) = do (res, newRnds, newState) <- runCommand rnds state c run fuel newRnds newState (f res) run Dry rnds state p = pure (Nothing, rnds, state) {- 1 -} updateGameState : (GameState -> GameState) -> Command () updateGameState f = do st <- GetGameState PutGameState (f st) mutual correct : ConsoleIO GameState correct = do PutStr "Correct!\n" updateGameState addCorrect quiz wrong : Int -> ConsoleIO GameState wrong ans = do PutStr ("Wrong, the answer is " ++ show ans ++ "\n") updateGameState addWrong quiz data Input = Answer Int | QuitCmd readInput : (prompt : String) -> Command Input readInput prompt = do PutStr prompt answer <- GetLine if toLower answer == "quit" then Pure QuitCmd else Pure (Answer (cast answer)) quiz : ConsoleIO GameState quiz = do num1 <- GetRandom num2 <- GetRandom st <- GetGameState PutStr (show st ++ "\n") input <- readInput (show num1 ++ " * " ++ show num2 ++ "? ") case input of Answer answer => if answer == num1 * num2 then correct else wrong (num1 * num2) QuitCmd => Quit st partial main : IO () main = do seed <- time (Just score, _, state) <- run forever (randoms (fromInteger seed)) initState quiz | _ => putStrLn "Ran out of fuel" putStrLn ("Final score: " ++ show state) ================================================ FILE: Chapter12/Exercises/ex_12_3b.idr ================================================ record Votes where constructor MkVotes upvotes : Integer downvotes : Integer record Article where constructor MkArticle title : String url : String score : Votes initPage : (title : String) -> (url : String) -> Article initPage title url = MkArticle title url (MkVotes 0 0) badSite : Article badSite = MkArticle "Bad Page" "http://example.com/bad" (MkVotes 5 47) goodSite : Article goodSite = MkArticle "Good Page" "http://example.com/good" (MkVotes 101 7) {- 3 -} getScore : Article -> Integer getScore article = upvotes (score article) - downvotes (score article) {- 4 -} addUpvote : Article -> Article addUpvote = record { score->upvotes $= (+1) } addDownvote : Article -> Article addDownvote = record { score->downvotes $= (+1) } ================================================ FILE: Chapter12/Record.idr ================================================ record Book where constructor MkBook title : String author : String record Album where constructor MkAlbum title : String tracks : List String ================================================ FILE: Chapter12/State.idr ================================================ import Control.Monad.State increment : Nat -> State Nat () increment inc = do current <- get put (current + inc) ================================================ FILE: Chapter12/StateMonad.idr ================================================ data State : (stateType : Type) -> Type -> Type where Get : State stateType stateType Put : stateType -> State stateType () Pure : ty -> State stateType ty Bind : State stateType a -> (a -> State stateType b) -> State stateType b get : State stateType stateType get = Get put : stateType -> State stateType () put = Put mutual Functor (State stateType) where map func x = do val <- x pure (func val) Applicative (State stateType) where pure = Pure (<*>) f a = do f' <- f a' <- a pure (f' a') Monad (State stateType) where (>>=) = Bind {- (>>=) : State stateType a -> (a -> State stateType b) -> State stateType b (>>=) = Bind -} runState : State stateType a -> (st : stateType) -> (a, stateType) runState Get st = (st, st) runState (Put newState) st = ((), newState) runState (Pure x) st = (x, st) runState (Bind cmd prog) st = let (val, nextState) = runState cmd st in runState (prog val) nextState addIfPositive : Integer -> State Integer Bool addIfPositive val = do when (val > 0) $ do current <- get put (current + val) pure (val > 0) addPositives : List Integer -> State Integer Nat addPositives vals = do added <- traverse addIfPositive vals pure (length (filter id added)) ================================================ FILE: Chapter12/Traverse.idr ================================================ crew : List String crew = ["Lister", "Rimmer", "Kryten", "Cat"] main : IO () main = do putStr "Display Crew? " x <- getLine when (x == "yes") $ do traverse putStrLn crew pure () putStrLn "Done" ================================================ FILE: Chapter12/TreeLabel.idr ================================================ data Tree a = Empty | Node (Tree a) a (Tree a) testTree : Tree String testTree = Node (Node (Node Empty "Jim" Empty) "Fred" (Node Empty "Sheila" Empty)) "Alice" (Node Empty "Bob" (Node Empty "Eve" Empty)) flatten : Tree a -> List a flatten Empty = [] flatten (Node left val right) = flatten left ++ val :: flatten right treeLabelWith : Stream labelType -> Tree a -> (Stream labelType, Tree (labelType, a)) treeLabelWith lbls Empty = (lbls, Empty) treeLabelWith lbls (Node left val right) = let (this :: lblsLeft, left_labelled) = treeLabelWith lbls left (lblsRight, right_labelled) = treeLabelWith lblsLeft right in (lblsRight, Node left_labelled (this, val) right_labelled) treeLabel : Tree a -> Tree (Integer, a) treeLabel tree = snd (treeLabelWith [1..] tree) ================================================ FILE: Chapter12/TreeLabelState.idr ================================================ import Control.Monad.State data Tree a = Empty | Node (Tree a) a (Tree a) testTree : Tree String testTree = Node (Node (Node Empty "Jim" Empty) "Fred" (Node Empty "Sheila" Empty)) "Alice" (Node Empty "Bob" (Node Empty "Eve" Empty)) flatten : Tree a -> List a flatten Empty = [] flatten (Node left val right) = flatten left ++ val :: flatten right treeLabelWith : Tree a -> State (Stream labelType) (Tree (labelType, a)) treeLabelWith Empty = pure Empty treeLabelWith (Node left val right) = do left_labelled <- treeLabelWith left (this :: rest) <- get put rest right_labelled <- treeLabelWith right pure (Node left_labelled (this, val) right_labelled) treeLabel : Tree a -> Tree (Integer, a) treeLabel tree = evalState (treeLabelWith tree) [1..] ================================================ FILE: Chapter12/TreeLabelType.idr ================================================ data Tree a = Empty | Node (Tree a) a (Tree a) testTree : Tree String testTree = Node (Node (Node Empty "Jim" Empty) "Fred" (Node Empty "Sheila" Empty)) "Alice" (Node Empty "Bob" (Node Empty "Eve" Empty)) flatten : Tree a -> List a flatten Empty = [] flatten (Node left val right) = flatten left ++ val :: flatten right data State : (stateType : Type) -> Type -> Type where Get : State stateType stateType Put : stateType -> State stateType () Pure : ty -> State stateType ty Bind : State stateType a -> (a -> State stateType b) -> State stateType b {- (>>=) : State stateType a -> (a -> State stateType b) -> State stateType b (>>=) = Bind -} mutual Functor (State stateType) where map func x = do val <- x Pure (func val) Applicative (State stateType) where pure x = Pure x (<*>) f a = do func <- f arg <- a pure (func arg) Monad (State stateType) where (>>=) = Bind runState : State stateType a -> (st : stateType) -> (a, stateType) runState Get st = (st, st) runState (Put newState) st = ((), newState) runState (Pure x) st = (x, st) runState (Bind cmd prog) st = let (val, nextState) = runState cmd st in runState (prog val) nextState treeLabelWith : Tree a -> State (Stream labelType) (Tree (labelType, a)) treeLabelWith Empty = Pure Empty treeLabelWith (Node left val right) = do left_labelled <- treeLabelWith left (this :: rest) <- Get Put rest right_labelled <- treeLabelWith right Pure (Node left_labelled (this, val) right_labelled) treeLabel : Tree a -> Tree (Integer, a) treeLabel tree = fst (runState (treeLabelWith tree) [1..]) ================================================ FILE: Chapter13/Door.idr ================================================ data DoorState = DoorOpen | DoorClosed data DoorCmd : Type -> DoorState -> DoorState -> Type where Open : DoorCmd () DoorClosed DoorOpen Close : DoorCmd () DoorOpen DoorClosed RingBell : DoorCmd () DoorClosed DoorClosed Pure : ty -> DoorCmd ty state state (>>=) : DoorCmd a state1 state2 -> (a -> DoorCmd b state2 state3) -> DoorCmd b state1 state3 doorProg : DoorCmd () DoorClosed DoorClosed doorProg = do RingBell Open Close ================================================ FILE: Chapter13/Exercises/ex_13_1.idr ================================================ namespace Q1 data DoorState = DoorOpen | DoorClosed data DoorCmd : Type -> DoorState -> DoorState -> Type where Open : DoorCmd () DoorClosed DoorOpen Close : DoorCmd () DoorOpen DoorClosed RingBell : DoorCmd () state state Pure : ty -> DoorCmd ty state state (>>=) : DoorCmd a state1 state2 -> (a -> DoorCmd b state2 state3) -> DoorCmd b state1 state3 doorProg : DoorCmd () DoorClosed DoorClosed doorProg = do RingBell Open RingBell Close namespace Q2 data GuessCmd : Type -> Nat -> Nat -> Type where Try : Integer -> GuessCmd Ordering (S guesses) guesses Pure : ty -> GuessCmd ty state state (>>=) : GuessCmd a state1 state2 -> (a -> GuessCmd b state2 state3) -> GuessCmd b state1 state3 threeGuesses : GuessCmd () 3 0 threeGuesses = do Try 10 Try 20 Try 15 Pure () {- no_guesses : GuessCmd () 0 0 no_guesses = do Try 10 Pure () -} namespace Q3 data Matter = Solid | Liquid | Gas data MatterCmd : Type -> Matter -> Matter -> Type where Melt : MatterCmd () Solid Liquid Boil : MatterCmd () Liquid Gas Condense : MatterCmd () Gas Liquid Freeze : MatterCmd () Liquid Solid Pure : ty -> MatterCmd ty state state (>>=) : MatterCmd a state1 state2 -> (a -> MatterCmd b state2 state3) -> MatterCmd b state1 state3 iceSteam : MatterCmd () Solid Gas iceSteam = do Melt Boil steamIce : MatterCmd () Gas Solid steamIce = do Condense Freeze {- overMelt : MatterCmd () Solid Gas overMelt = do Melt Melt -} ================================================ FILE: Chapter13/Exercises/ex_13_2.idr ================================================ import Data.Vect data StackCmd : Type -> Nat -> Nat -> Type where Push : Integer -> StackCmd () height (S height) Pop : StackCmd Integer (S height) height Top : StackCmd Integer (S height) (S height) GetStr : StackCmd String height height PutStr : String -> StackCmd () height height Pure : ty -> StackCmd ty height height (>>=) : StackCmd a height1 height2 -> (a -> StackCmd b height2 height3) -> StackCmd b height1 height3 runStack : (stk : Vect inHeight Integer) -> StackCmd ty inHeight outHeight -> IO (ty, Vect outHeight Integer) runStack stk (Push val) = pure ((), val :: stk) runStack (val :: stk) Pop = pure (val, stk) runStack (val :: stk) Top = pure (val, val :: stk) runStack stk GetStr = do x <- getLine pure (x, stk) runStack stk (PutStr x) = do putStr x pure ((), stk) runStack stk (Pure x) = pure (x, stk) runStack stk (x >>= f) = do (x', newStk) <- runStack stk x runStack newStk (f x') data StackIO : Nat -> Type where Do : StackCmd a height1 height2 -> (a -> Inf (StackIO height2)) -> StackIO height1 namespace StackDo (>>=) : StackCmd a height1 height2 -> (a -> Inf (StackIO height2)) -> StackIO height1 (>>=) = Do data Fuel = Dry | More (Lazy Fuel) partial forever : Fuel forever = More forever run : Fuel -> Vect height Integer -> StackIO height -> IO () run (More fuel) stk (Do c f) = do (res, newStk) <- runStack stk c run fuel newStk (f res) run Dry stk p = pure () doAdd : StackCmd () (S (S height)) (S height) doAdd = do val1 <- Pop val2 <- Pop Push (val1 + val2) doSub : StackCmd () (S (S height)) (S height) doSub = do val1 <- Pop val2 <- Pop Push (val2 - val1) doMul : StackCmd () (S (S height)) (S height) doMul = do val1 <- Pop val2 <- Pop Push (val1 * val2) mutual tryAdd : StackIO height tryAdd {height = (S (S h))} = do doAdd result <- Top PutStr (show result ++ "\n") stackCalc tryAdd = do PutStr "Fewer than two items on the stack\n" stackCalc trySub : StackIO height trySub {height = (S (S h))} = do doSub result <- Top PutStr (show result ++ "\n") stackCalc trySub = do PutStr "Fewer than two items on the stack\n" stackCalc tryMul : StackIO height tryMul {height = (S (S h))} = do doMul result <- Top PutStr (show result ++ "\n") stackCalc tryMul = do PutStr "Fewer than two items on the stack\n" stackCalc tryNeg : StackIO height tryNeg {height = (S h)} = do x <- Pop Push (-x) result <- Top PutStr (show result ++ "\n") stackCalc tryNeg = do PutStr "Nothing on the stack\n" stackCalc tryDup : StackIO height tryDup {height = (S h)} = do x <- Top Push x PutStr ("Duplicated " ++ show x ++ "\n") stackCalc tryDup = do PutStr "Nothing on the stack\n" stackCalc tryDiscard : StackIO height tryDiscard {height = (S h)} = do x <- Pop PutStr ("Discarded " ++ show x ++ "\n") stackCalc tryDiscard = do PutStr "Nothing on the stack\n" stackCalc data StkInput = Number Integer | Add | Subtract | Multiply | Negate | Discard | Duplicate strToInput : String -> Maybe StkInput strToInput "add" = Just Add strToInput "subtract" = Just Subtract strToInput "multiply" = Just Multiply strToInput "negate" = Just Negate strToInput "discard" = Just Discard strToInput "duplicate" = Just Duplicate strToInput x = if all isDigit (unpack x) then Just (Number (cast x)) else Nothing stackCalc : StackIO height stackCalc = do PutStr "> " input <- GetStr case strToInput input of Nothing => do PutStr "Invalid input\n" stackCalc Just (Number x) => do Push x stackCalc Just Add => tryAdd Just Subtract => trySub Just Multiply => tryMul Just Negate => tryNeg Just Discard => tryDiscard Just Duplicate => tryDup main : IO () main = run forever [] stackCalc ================================================ FILE: Chapter13/Stack.idr ================================================ import Data.Vect data StackCmd : Type -> Nat -> Nat -> Type where Push : Integer -> StackCmd () height (S height) Pop : StackCmd Integer (S height) height Top : StackCmd Integer (S height) (S height) Pure : ty -> StackCmd ty height height (>>=) : StackCmd a height1 height2 -> (a -> StackCmd b height2 height3) -> StackCmd b height1 height3 runStack : (stk : Vect inHeight Integer) -> StackCmd ty inHeight outHeight -> (ty, Vect outHeight Integer) runStack stk (Push val) = ((), val :: stk) runStack (val :: stk) Pop = (val, stk) runStack (val :: stk) Top = (val, val :: stk) runStack stk (Pure x) = (x, stk) runStack stk (x >>= f) = let (x', newStk) = runStack stk x in runStack newStk (f x') testAdd : StackCmd Integer 0 0 testAdd = do Push 10 -- Push 20 val1 <- Pop val2 <- Pop Pure (val1 + val2) doAdd : StackCmd () (S (S height)) (S height) doAdd = do val1 <- Pop val2 <- Pop Push (val1 + val2) ================================================ FILE: Chapter13/StackIO.idr ================================================ import Data.Vect data StackCmd : Type -> Nat -> Nat -> Type where Push : Integer -> StackCmd () height (S height) Pop : StackCmd Integer (S height) height Top : StackCmd Integer (S height) (S height) GetStr : StackCmd String height height PutStr : String -> StackCmd () height height Pure : ty -> StackCmd ty height height (>>=) : StackCmd a height1 height2 -> (a -> StackCmd b height2 height3) -> StackCmd b height1 height3 runStack : (stk : Vect inHeight Integer) -> StackCmd ty inHeight outHeight -> IO (ty, Vect outHeight Integer) runStack stk (Push val) = pure ((), val :: stk) runStack (val :: stk) Pop = pure (val, stk) runStack (val :: stk) Top = pure (val, val :: stk) runStack stk GetStr = do x <- getLine pure (x, stk) runStack stk (PutStr x) = do putStr x pure ((), stk) runStack stk (Pure x) = pure (x, stk) runStack stk (x >>= f) = do (x', newStk) <- runStack stk x runStack newStk (f x') testAdd : StackCmd () 0 0 testAdd = do Push 10 x <- GetStr Push (cast x) val1 <- Pop val2 <- Pop PutStr (show (val1 + val2) ++ "\n") data StackIO : Nat -> Type where Do : StackCmd a height1 height2 -> (a -> Inf (StackIO height2)) -> StackIO height1 namespace StackDo (>>=) : StackCmd a height1 height2 -> (a -> Inf (StackIO height2)) -> StackIO height1 (>>=) = Do data Fuel = Dry | More (Lazy Fuel) partial forever : Fuel forever = More forever run : Fuel -> Vect height Integer -> StackIO height -> IO () run (More fuel) stk (Do c f) = do (res, newStk) <- runStack stk c run fuel newStk (f res) run Dry stk p = pure () doAdd : StackCmd () (S (S height)) (S height) doAdd = do val1 <- Pop val2 <- Pop Push (val1 + val2) mutual tryAdd : StackIO height tryAdd {height = (S (S h))} = do doAdd result <- Top PutStr (show result ++ "\n") stackCalc tryAdd = do PutStr "Fewer than two items on the stack\n" stackCalc data StkInput = Number Integer | Add strToInput : String -> Maybe StkInput strToInput "" = Nothing strToInput "add" = Just Add strToInput x = if all isDigit (unpack x) then Just (Number (cast x)) else Nothing stackCalc : StackIO height stackCalc = do PutStr "> " input <- GetStr case strToInput input of Nothing => do PutStr "Invalid input\n" stackCalc Just (Number x) => do Push x stackCalc Just Add => tryAdd main : IO () main = run forever [] stackCalc ================================================ FILE: Chapter13/Vending.idr ================================================ VendState : Type VendState = (Nat, Nat) data Input = COIN | VEND | CHANGE | REFILL Nat strToInput : String -> Maybe Input strToInput "insert" = Just COIN strToInput "vend" = Just VEND strToInput "change" = Just CHANGE strToInput x = if all isDigit (unpack x) then Just (REFILL (cast x)) else Nothing data MachineCmd : Type -> VendState -> VendState -> Type where InsertCoin : MachineCmd () (pounds, chocs) (S pounds, chocs) Vend : MachineCmd () (S pounds, S chocs) (pounds, chocs) GetCoins : MachineCmd () (pounds, chocs) (Z, chocs) Display : String -> MachineCmd () state state Refill : (bars : Nat) -> MachineCmd () (Z, chocs) (Z, bars + chocs) GetInput : MachineCmd (Maybe Input) state state Pure : ty -> MachineCmd ty state state (>>=) : MachineCmd a state1 state2 -> (a -> MachineCmd b state2 state3) -> MachineCmd b state1 state3 data MachineIO : VendState -> Type where Do : MachineCmd a state1 state2 -> (a -> Inf (MachineIO state2)) -> MachineIO state1 runMachine : MachineCmd ty inState outState -> IO ty runMachine InsertCoin = putStrLn "Coin inserted" runMachine Vend = putStrLn "Please take your chocolate" runMachine {inState = (pounds, _)} GetCoins = putStrLn (show pounds ++ " coins returned") runMachine (Display str) = putStrLn str runMachine (Refill bars) = putStrLn ("Chocolate remaining: " ++ show bars) runMachine {inState = (pounds, chocs)} GetInput = do putStrLn ("Coins: " ++ show pounds ++ "; " ++ "Stock: " ++ show chocs) putStr "> " x <- getLine pure (strToInput x) runMachine (Pure x) = pure x runMachine (cmd >>= prog) = do x <- runMachine cmd runMachine (prog x) data Fuel = Dry | More (Lazy Fuel) partial forever : Fuel forever = More forever run : Fuel -> MachineIO state -> IO () run (More fuel) (Do c f) = do res <- runMachine c run fuel (f res) run Dry p = pure () namespace MachineDo (>>=) : MachineCmd a state1 state2 -> (a -> Inf (MachineIO state2)) -> MachineIO state1 (>>=) = Do mutual vend : MachineIO (pounds, chocs) vend {pounds = S p} {chocs = S c} = do Vend Display "Enjoy!" machineLoop vend {pounds = Z} = do Display "Insert a coin" machineLoop vend {chocs = Z} = do Display "Out of stock" machineLoop refill : (num : Nat) -> MachineIO (pounds, chocs) refill {pounds = Z} num = do Refill num machineLoop refill _ = do Display "Can't refill: Coins in machine" machineLoop machineLoop : MachineIO (pounds, chocs) machineLoop = do Just x <- GetInput | Nothig => do Display "Invalid input" machineLoop case x of COIN => do InsertCoin machineLoop VEND => vend CHANGE => do GetCoins Display "Change returned" machineLoop REFILL num => refill num main : IO () main = run forever (machineLoop {pounds = 0} {chocs = 1}) ================================================ FILE: Chapter14/ATM.idr ================================================ import Data.Vect data ATMState = Ready | CardInserted | Session data PINCheck = CorrectPIN | IncorrectPIN PIN : Type PIN = Vect 4 Char data HasCard : ATMState -> Type where HasCI : HasCard CardInserted HasSession : HasCard Session data ATMCmd : (res : Type) -> ATMState -> (res -> ATMState) -> Type where InsertCard : ATMCmd () Ready (const CardInserted) EjectCard : {auto prf : HasCard state} -> ATMCmd () state (const Ready) GetPIN : ATMCmd PIN CardInserted (const CardInserted) CheckPIN : PIN -> ATMCmd PINCheck CardInserted (\check => case check of CorrectPIN => Session IncorrectPIN => CardInserted) GetAmount : ATMCmd Nat state (const state) Dispense : (amount : Nat) -> ATMCmd () Session (const Session) Message : String -> ATMCmd () state (const state) Pure : (res : ty) -> ATMCmd ty (state_fn res) state_fn (>>=) : ATMCmd a state1 state2_fn -> ((res : a) -> ATMCmd b (state2_fn res) state3_fn) -> ATMCmd b state1 state3_fn readVect : (n : Nat) -> IO (Vect n Char) readVect Z = do discard <- getLine -- rest of input up to enter pure [] readVect (S k) = do ch <- getChar chs <- readVect k pure (ch :: chs) testPIN : Vect 4 Char testPIN = ['1', '2', '3', '4'] insertEject : ATMCmd () Ready (const Ready) insertEject = do InsertCard EjectCard -- ?insertEject_rhs -- badATM : ATMCmd () Ready (const Ready) -- badATM = EjectCard runATM : ATMCmd res instate outstate_fn -> IO res runATM InsertCard = do putStrLn "Please insert your card (press enter)" x <- getLine pure () runATM EjectCard = putStrLn "Card ejected" runATM GetPIN = do putStr "Enter PIN: " readVect 4 runATM (CheckPIN pin) = if pin == testPIN then pure CorrectPIN else pure IncorrectPIN runATM GetAmount = do putStr "How much would you like? " x <- getLine pure (cast x) runATM (Dispense amount) = putStrLn ("Here is " ++ show amount) runATM (Message msg) = putStrLn msg runATM (Pure res) = pure res runATM (x >>= f) = do x' <- runATM x runATM (f x') atm : ATMCmd () Ready (const Ready) atm = do InsertCard pin <- GetPIN pinOK <- CheckPIN pin case pinOK of CorrectPIN => do cash <- GetAmount Dispense cash EjectCard IncorrectPIN => EjectCard atm_alt : ATMCmd () Ready (const Ready) atm_alt = do InsertCard pin <- GetPIN cash <- GetAmount pinOK <- CheckPIN pin Message "Checking Card" case pinOK of CorrectPIN => do Dispense cash EjectCard Message "Please remove your card and cash" IncorrectPIN => do Message "Incorrect PIN" EjectCard ================================================ FILE: Chapter14/DoorJam.idr ================================================ data DoorState = DoorOpen | DoorClosed data DoorResult = OK | Jammed data DoorCmd : (ty : Type) -> DoorState -> (ty -> DoorState) -> Type where Open : DoorCmd DoorResult DoorClosed (\res => case res of OK => DoorOpen Jammed => DoorClosed) Close : DoorCmd () DoorOpen (const DoorClosed) RingBell : DoorCmd () DoorClosed (const DoorClosed) Display : String -> DoorCmd () state (const state) Pure : (res : ty) -> DoorCmd ty (state_fn res) state_fn (>>=) : DoorCmd a state1 state2_fn -> ((res : a) -> DoorCmd b (state2_fn res) state3_fn) -> DoorCmd b state1 state3_fn logOpen : DoorCmd DoorResult DoorClosed (\res => case res of OK => DoorOpen Jammed => DoorClosed) logOpen = do Display "Trying to open the door" OK <- Open | Jammed => do Display "Jammed" Pure Jammed Display "Success" Pure OK doorProg : DoorCmd () DoorClosed (const DoorClosed) doorProg = do RingBell jam <- Open Display "Trying to open the door" case jam of OK => do Display "Glad To Be Of Service" Close Jammed => Display "Door Jammed" doorProg2 : DoorCmd () DoorClosed (const DoorClosed) doorProg2 = do RingBell OK <- Open | Jammed => Display "Door Jammed" Display "Glad To Be Of Service" Close OK <- Open | Jammed => Display "Door Jammed" Display "Glad To Be Of Service" Close ================================================ FILE: Chapter14/Exercises/ex_14_2_1.idr ================================================ data Access = LoggedOut | LoggedIn data PwdCheck = Correct | Incorrect data ShellCmd : (ty : Type) -> Access -> (ty -> Access) -> Type where Password : String -> ShellCmd PwdCheck LoggedOut (\res => case res of Correct => LoggedIn Incorrect => LoggedOut) Logout : ShellCmd () LoggedIn (const LoggedOut) GetSecret : ShellCmd String LoggedIn (const LoggedIn) PutStr : String -> ShellCmd () state (const state) Pure : (res : ty) -> ShellCmd ty (state_fn res) state_fn (>>=) : ShellCmd a state1 state2_fn -> ((res : a) -> ShellCmd b (state2_fn res) state3_fn) -> ShellCmd b state1 state3_fn session : ShellCmd () LoggedOut (const LoggedOut) session = do Correct <- Password "wurzel" | Incorrect => PutStr "Wrong password" msg <- GetSecret PutStr ("Secret code: " ++ show msg ++ "\n") Logout {- badSession : ShellCmd () LoggedOut (const LoggedOut) badSession = do Password "wurzel" msg <- GetSecret PutStr ("Secret code: " ++ show msg ++ "\n") Logout noLogout : ShellCmd () LoggedOut (const LoggedOut) noLogout = do Correct <- Password "wurzel" | Incorrect => PutStr "Wrong password" msg <- GetSecret PutStr ("Secret code: " ++ show msg ++ "\n") -} ================================================ FILE: Chapter14/Exercises/ex_14_2_2.idr ================================================ VendState : Type VendState = (Nat, Nat) data Input = COIN | VEND | CHANGE | REFILL Nat strToInput : String -> Maybe Input strToInput "insert" = Just COIN strToInput "vend" = Just VEND strToInput "change" = Just CHANGE strToInput x = if all isDigit (unpack x) then Just (REFILL (cast x)) else Nothing data CoinResult = Inserted | Rejected data MachineCmd : (res : Type) -> VendState -> (res -> VendState) -> Type where InsertCoin : MachineCmd CoinResult (pounds, chocs) (\res => case res of Inserted => (S pounds, chocs) Rejected => (pounds, chocs)) Vend : MachineCmd () (S pounds, S chocs) (const (pounds, chocs)) GetCoins : MachineCmd () (pounds, chocs) (const (Z, chocs)) Display : String -> MachineCmd () state (const state) Refill : (bars : Nat) -> MachineCmd () (Z, chocs) (const (Z, bars + chocs)) GetInput : MachineCmd (Maybe Input) state (const state) Pure : (res : ty) -> MachineCmd ty (state_fn res) state_fn (>>=) : MachineCmd a state1 state2_fn -> ((x : a) -> MachineCmd b (state2_fn x) state3_fn) -> MachineCmd b state1 state3_fn data MachineIO : VendState -> Type where Do : MachineCmd a state1 state2_fn -> ((x : a) -> Inf (MachineIO (state2_fn x))) -> MachineIO state1 namespace MachineDo (>>=) : MachineCmd a state1 state2_fn -> ((x : a) -> Inf (MachineIO (state2_fn x))) -> MachineIO state1 (>>=) = Do mutual vend : MachineIO (pounds, chocs) vend {pounds = S p} {chocs = S c} = do Vend Display "Enjoy!" machineLoop vend {pounds = Z} = do Display "Insert a coin" machineLoop vend {chocs = Z} = do Display "Out of stock" machineLoop refill : (num : Nat) -> MachineIO (pounds, chocs) refill {pounds = Z} num = do Refill num machineLoop refill _ = do Display "Can't refill: Coins in machine" machineLoop machineLoop : MachineIO (pounds, chocs) machineLoop = do Just x <- GetInput | Nothig => do Display "Invalid input" machineLoop case x of COIN => do res <- InsertCoin case res of Inserted => do Display "Coin inserted" machineLoop Rejected => do Display "Coin rejected" machineLoop VEND => vend CHANGE => do GetCoins Display "Change returned" machineLoop REFILL num => refill num ================================================ FILE: Chapter14/Hangman.idr ================================================ import Data.Vect %default total data GameState : Type where NotRunning : GameState Running : (guesses : Nat) -> (letters : Nat) -> GameState letters : String -> List Char letters str = nub (map toUpper (unpack str)) data GuessResult = Correct | Incorrect data GameCmd : (ty : Type) -> GameState -> (ty -> GameState) -> Type where NewGame : (word : String) -> GameCmd () NotRunning (const (Running 6 (length (letters word)))) Won : GameCmd () (Running (S guesses) 0) (const NotRunning) Lost : GameCmd () (Running 0 (S guesses)) (const NotRunning) Guess : (c : Char) -> GameCmd GuessResult (Running (S guesses) (S letters)) (\res => case res of Correct => Running (S guesses) letters Incorrect => Running guesses (S letters)) ShowState : GameCmd () state (const state) Message : String -> GameCmd () state (const state) ReadGuess : GameCmd Char state (const state) Pure : (res : ty) -> GameCmd ty (state_fn res) state_fn (>>=) : GameCmd a state1 state2_fn -> ((res : a) -> GameCmd b (state2_fn res) state3_fn) -> GameCmd b state1 state3_fn namespace Loop data GameLoop : (ty : Type) -> GameState -> (ty -> GameState) -> Type where (>>=) : GameCmd a state1 state2_fn -> ((res : a) -> Inf (GameLoop b (state2_fn res) state3_fn)) -> GameLoop b state1 state3_fn Exit : GameLoop () NotRunning (const NotRunning) gameLoop : GameLoop () (Running (S guesses) (S letters)) (const NotRunning) gameLoop {guesses} {letters} = do ShowState g <- ReadGuess ok <- Guess g case ok of Correct => case letters of Z => do Won ShowState Exit S k => do Message "Correct" gameLoop Incorrect => case guesses of Z => do Lost ShowState Exit (S k) => do Message "Incorrect" gameLoop hangman : GameLoop () NotRunning (const NotRunning) hangman = do NewGame "testing" gameLoop data Game : GameState -> Type where GameStart : Game NotRunning GameWon : (word : String) -> Game NotRunning GameLost : (word : String) -> Game NotRunning InProgress : (word : String) -> (guesses : Nat) -> (missing : Vect letters Char) -> Game (Running guesses letters) Show (Game g) where show GameStart = "Starting" show (GameWon word) = "Game won: word was " ++ word show (GameLost word) = "Game lost: word was " ++ word show (InProgress word guesses missing) = "\n" ++ pack (map hideMissing (unpack word)) ++ "\n" ++ show guesses ++ " guesses left" where hideMissing : Char -> Char hideMissing c = if c `elem` missing then '-' else c data Fuel = Dry | More (Lazy Fuel) total removeElem : (value : a) -> (xs : Vect (S n) a) -> {auto prf : Elem value xs} -> Vect n a removeElem value (value :: ys) {prf = Here} = ys removeElem {n = Z} value (y :: []) {prf = There later} = absurd later removeElem {n = (S k)} value (y :: ys) {prf = There later} = y :: removeElem value ys data GameResult : (ty : Type) -> (ty -> GameState) -> Type where OK : (res : ty) -> Game (outstate_fn res) -> GameResult ty outstate_fn OutOfFuel : GameResult ty outstate_fn ok : (res : ty) -> Game (outstate_fn res) -> IO (GameResult ty outstate_fn) ok res st = pure (OK res st) runCmd : Fuel -> Game instate -> GameCmd ty instate outstate_fn -> IO (GameResult ty outstate_fn) runCmd fuel state (NewGame word) = ok () (InProgress (toUpper word) _ (fromList (letters word))) runCmd fuel (InProgress word _ missing) Won = ok () (GameWon word) runCmd fuel (InProgress word _ missing) Lost = ok () (GameLost word) runCmd fuel (InProgress word _ missing) (Guess c) = case isElem c missing of Yes prf => ok Correct (InProgress word _ (removeElem c missing)) No contra => ok Incorrect (InProgress word _ missing) runCmd fuel state ShowState = do printLn state ok () state runCmd fuel state (Message str) = do putStrLn str ok () state runCmd (More fuel) st ReadGuess = do putStr "Guess: " input <- getLine case unpack input of [x] => if isAlpha x then ok (toUpper x) st else do putStrLn "Invalid input" runCmd fuel st ReadGuess _ => do putStrLn "Invalid input" runCmd fuel st ReadGuess runCmd fuel state (Pure res) = ok res state runCmd fuel st (cmd >>= next) = do OK cmdRes newSt <- runCmd fuel st cmd | OutOfFuel => pure OutOfFuel runCmd fuel newSt (next cmdRes) runCmd Dry _ _ = pure OutOfFuel run : Fuel -> Game instate -> GameLoop ty instate outstate_fn -> IO (GameResult ty outstate_fn) run Dry _ _ = pure OutOfFuel run (More fuel) st (cmd >>= next) = do OK cmdRes newSt <- runCmd fuel st cmd | OutOfFuel => pure OutOfFuel run fuel newSt (next cmdRes) run (More fuel) st Exit = pure (OK () st) %default partial forever : Fuel forever = More forever main : IO () main = do run forever GameStart hangman pure () ================================================ FILE: Chapter15/AdderChannel.idr ================================================ import System.Concurrency.Channels data Message = Add Nat Nat adder : IO () adder = do Just sender_chan <- listen 1 | Nothing => adder Just msg <- unsafeRecv Message sender_chan | Nothing => adder case msg of Add x y => do ok <- unsafeSend sender_chan (x + y) adder main : IO () main = do Just adder_id <- spawn adder | Nothing => putStrLn "Spawn failed" Just chan <- connect adder_id | Nothing => putStrLn "Connection failed" ok <- unsafeSend chan (Add 2 3) Just answer <- unsafeRecv String chan | Nothing => putStrLn "Send failed" printLn answer ================================================ FILE: Chapter15/ListProc.idr ================================================ import ProcessLib data ListAction : Type where Length : List elem -> ListAction Append : List elem -> List elem -> ListAction ListType : ListAction -> Type ListType (Length xs) = Nat ListType (Append {elem} xs ys) = List elem total procList : Service ListType () procList = do Respond (\msg => case msg of Length xs => Pure (length xs) Append xs ys => Pure (xs ++ ys)) Loop procList procMain : Client () procMain = do Just list <- Spawn procList | Nothing => Action (putStrLn "Spawn failed") len <- Request list (Length [1,2,3]) Action (printLn len) app <- Request list (Append [1,2,3] [4,5,6]) Action (printLn app) ================================================ FILE: Chapter15/Process.idr ================================================ import System.Concurrency.Channels data Message = Add Nat Nat data MessagePID = MkMessage PID data Process : Type -> Type where Request : MessagePID -> Message -> Process (Maybe Nat) Respond : ((msg : Message) -> Process Nat) -> Process (Maybe Message) Spawn : Process () -> Process (Maybe MessagePID) Loop : Inf (Process a) -> Process a Action : IO a -> Process a Pure : a -> Process a (>>=) : Process a -> (a -> Process b) -> Process b run : Process t -> IO t run (Request (MkMessage process) msg) = do Just chan <- connect process | _ => pure Nothing ok <- unsafeSend chan msg if ok then do Just x <- unsafeRecv Nat chan | Nothing => pure Nothing pure (Just x) else pure Nothing run (Respond calc) = do Just sender <- listen 1 | Nothing => pure Nothing -- No incoming connections Just msg <- unsafeRecv Message sender | Nothing => pure Nothing -- no message received res <- run (calc msg) unsafeSend sender res pure (Just msg) run (Spawn proc) = do Just pid <- spawn (run proc) | Nothing => pure Nothing pure (Just (MkMessage pid)) run (Loop action) = run action run (Action act) = act run (Pure val) = pure val run (act >>= next) = do x <- run act run (next x) procAdder : Process () procAdder = do Respond (\msg => case msg of Add x y => Pure (x + y)) procAdder procMain : Process () procMain = do Just adder_id <- Spawn procAdder | Nothing => Action (putStrLn "Spawn failed") Just answer <- Request adder_id (Add 2 3) | Nothing => Action (putStrLn "Request failed") Action (printLn answer) ================================================ FILE: Chapter15/ProcessIFace.idr ================================================ import System.Concurrency.Channels data Message = Add Nat Nat AdderType : Message -> Type AdderType (Add x y) = Nat data ListAction : Type where Length : List a -> ListAction Append : List a -> List a -> ListAction ListType : ListAction -> Type ListType (Length xs) = Nat ListType (Append {a} xs ys) = List a data MessagePID : (iface : reqType -> Type) -> Type where MkMessage : PID -> MessagePID iface NoRecv : Void -> Type NoRecv = const Void data ProcState = Ready | Sent | Looping data Process : (iface : reqType -> Type) -> Type -> ProcState -> ProcState -> Type where Request : MessagePID service_iface -> (msg : service_reqType) -> Process iface (service_iface msg) st st Respond : ((msg : reqType) -> Process iface (iface msg) Ready Ready) -> Process iface (Maybe reqType) st Sent Spawn : Process service_iface () Ready Looping -> Process iface (Maybe (MessagePID service_iface)) st st Loop : Inf (Process iface a Ready Looping) -> Process iface a Sent Looping Action : IO a -> Process iface a st st Pure : a -> Process iface a st st (>>=) : Process iface a st1 st2 -> (a -> Process iface b st2 st3) -> Process iface b st1 st3 public export data Fuel = Dry | More (Lazy Fuel) export partial forever : Fuel forever = More forever total run : Fuel -> Process iface t in_state out_state -> IO (Maybe t) run fuel (Request {service_iface} (MkMessage process) msg) = do Just chan <- connect process | _ => pure Nothing ok <- unsafeSend chan msg if ok then do Just x <- unsafeRecv (service_iface msg) chan | Nothing => pure Nothing pure (Just x) else pure Nothing run fuel (Respond {reqType} calc) = do Just sender <- listen 1 | Nothing => pure (Just Nothing) Just msg <- unsafeRecv reqType sender | Nothing => pure (Just Nothing) Just res <- run fuel (calc msg) | Nothing => pure Nothing unsafeSend sender res pure (Just (Just msg)) run (More fuel) (Loop proc) = run fuel proc run fuel (Spawn proc) = do Just pid <- spawn (do run fuel proc pure ()) | Nothing => pure (Just Nothing) pure (Just (Just (MkMessage pid))) run fuel (Action act) = do res <- act pure (Just res) run fuel (Pure val) = pure (Just val) run fuel (act >>= next) = do Just x <- run fuel act | Nothing => pure Nothing run fuel (next x) run Dry _ = pure Nothing Service : (iface : reqType -> Type) -> Type -> Type Service iface a = Process iface a Ready Looping Client : Type -> Type Client a = Process NoRecv a Ready Ready {- procAdderBad1 : Process () Ready Looping procAdderBad1 = do Action (putStrLn "I'm out of the office today") Loop procAdder_bad1 procAdderBad2 : Process () Ready Looping procAdderBad2 = Loop procAdder_bad2 -} procAdder : Service AdderType () procAdder = do Respond (\msg => case msg of Add x y => Pure (x + y)) Loop procAdder procMain : Client () procMain = do Just adder_id <- Spawn procAdder | Nothing => Action (putStrLn "Spawn failed") answer <- Request adder_id (Add 2 3) Action (printLn answer) partial runProc : Process iface () in_state out_state -> IO () runProc proc = do run forever proc pure () main : IO () main = runProc procMain ================================================ FILE: Chapter15/ProcessLib.idr ================================================ module ProcessLib import System.Concurrency.Channels %default total export data MessagePID : (iface : reqType -> Type) -> Type where MkMessage : PID -> MessagePID iface public export NoRecv : Void -> Type NoRecv = const Void public export data ProcState = Ready | Sent | Looping public export data Process : (iface : reqType -> Type) -> Type -> ProcState -> ProcState -> Type where Request : MessagePID service_iface -> (msg : service_reqType) -> Process iface (service_iface msg) st st Respond : ((msg : reqType) -> Process iface (iface msg) Ready Ready) -> Process iface (Maybe reqType) st Sent Spawn : Process service_iface () Ready Looping -> Process iface (Maybe (MessagePID service_iface)) st st Loop : Inf (Process iface a Ready Looping) -> Process iface a Sent Looping Action : IO a -> Process iface a st st Pure : a -> Process iface a st st (>>=) : Process iface a st1 st2 -> (a -> Process iface b st2 st3) -> Process iface b st1 st3 public export data Fuel = Dry | More (Lazy Fuel) export partial forever : Fuel forever = More forever export total run : Fuel -> Process iface t in_state out_state -> IO (Maybe t) run fuel (Request {service_iface} (MkMessage process) msg) = do Just chan <- connect process | _ => pure Nothing ok <- unsafeSend chan msg if ok then do Just x <- unsafeRecv (service_iface msg) chan | Nothing => pure Nothing pure (Just x) else pure Nothing run fuel (Respond {reqType} calc) = do Just sender <- listen 1 | Nothing => pure (Just Nothing) Just msg <- unsafeRecv reqType sender | Nothing => pure (Just Nothing) Just res <- run fuel (calc msg) | Nothing => pure Nothing unsafeSend sender res pure (Just (Just msg)) run (More fuel) (Loop proc) = run fuel proc run fuel (Spawn proc) = do Just pid <- spawn (do run fuel proc pure ()) | Nothing => pure (Just Nothing) pure (Just (Just (MkMessage pid))) run fuel (Action act) = do res <- act pure (Just res) run fuel (Pure val) = pure (Just val) run fuel (act >>= next) = do Just x <- run fuel act | Nothing => pure Nothing run fuel (next x) run Dry _ = pure Nothing public export Service : (iface : reqType -> Type) -> Type -> Type Service iface a = Process iface a Ready Looping public export Client : Type -> Type Client a = Process NoRecv a Ready Ready partial export runProc : Process iface () in_state out_state -> IO () runProc proc = do run forever proc pure () ================================================ FILE: Chapter15/ProcessLoop.idr ================================================ import System.Concurrency.Channels data Message = Add Nat Nat data MessagePID = MkMessage PID data Process : Type -> Type where Request : MessagePID -> Message -> Process (Maybe Nat) Respond : ((msg : Message) -> Process Nat) -> Process (Maybe Message) Spawn : Process () -> Process (Maybe MessagePID) Loop : Inf (Process a) -> Process a Action : IO a -> Process a Pure : a -> Process a (>>=) : Process a -> (a -> Process b) -> Process b public export data Fuel = Dry | More (Lazy Fuel) export partial forever : Fuel forever = More forever total run : Fuel -> Process t -> IO (Maybe t) run fuel (Request (MkMessage process) msg) = do Just chan <- connect process | _ => pure (Just Nothing) ok <- unsafeSend chan msg if ok then do Just x <- unsafeRecv Nat chan | Nothing => pure (Just Nothing) pure (Just (Just x)) else pure (Just Nothing) run fuel (Respond f) = do Just sender <- listen 1 | Nothing => pure (Just Nothing) Just msg <- unsafeRecv Message sender | Nothing => pure (Just Nothing) Just res <- run fuel (f msg) | Nothing => pure Nothing unsafeSend sender res pure (Just (Just msg)) run (More fuel) (Loop proc) = run fuel proc run fuel (Spawn proc) = do Just pid <- spawn (do run fuel proc pure ()) | Nothing => pure Nothing pure (Just (Just (MkMessage pid))) run fuel (Action act) = do res <- act pure (Just res) run fuel (Pure val) = pure (Just val) run fuel (act >>= next) = do Just x <- run fuel act | Nothing => pure Nothing run fuel (next x) run Dry _ = pure Nothing procAdder : Process () procAdder = do Respond (\msg => case msg of Add x y => Pure (x + y)) Loop procAdder procMain : Process () procMain = do Just adder_id <- Spawn procAdder | Nothing => Action (putStrLn "Spawn failed") Just answer <- Request adder_id (Add 2 3) | Nothing => Action (putStrLn "Request failed") Action (printLn answer) partial runProc : Process () -> IO () runProc proc = do run forever proc pure () main : IO () main = runProc procMain ================================================ FILE: Chapter15/ProcessState.idr ================================================ import System.Concurrency.Channels data Message = Add Nat Nat data MessagePID = MkMessage PID data ProcState = Ready | Sent | Looping data Process : Type -> ProcState -> ProcState -> Type where Request : MessagePID -> Message -> Process Nat st st Respond : ((msg : Message) -> Process Nat Ready Ready) -> Process (Maybe Message) st Sent Spawn : Process () Ready Looping -> Process (Maybe MessagePID) st st Loop : Inf (Process a Ready Looping) -> Process a Sent Looping Action : IO a -> Process a st st Pure : a -> Process a st st (>>=) : Process a st1 st2 -> (a -> Process b st2 st3) -> Process b st1 st3 public export data Fuel = Dry | More (Lazy Fuel) export partial forever : Fuel forever = More forever total run : Fuel -> Process t in_state out_state -> IO (Maybe t) run fuel (Request (MkMessage process) msg) = do Just chan <- connect process | _ => pure Nothing ok <- unsafeSend chan msg if ok then do Just x <- unsafeRecv Nat chan | Nothing => pure Nothing pure (Just x) else pure Nothing run fuel (Respond f) = do Just sender <- listen 1 | Nothing => pure (Just Nothing) Just msg <- unsafeRecv Message sender | Nothing => pure (Just Nothing) Just res <- run fuel (f msg) | Nothing => pure Nothing unsafeSend sender res pure (Just (Just msg)) run (More fuel) (Loop proc) = run fuel proc run fuel (Spawn proc) = do Just pid <- spawn (do run fuel proc pure ()) | Nothing => pure (Just Nothing) pure (Just (Just (MkMessage pid))) run fuel (Action act) = do res <- act pure (Just res) run fuel (Pure val) = pure (Just val) run fuel (act >>= next) = do Just x <- run fuel act | Nothing => pure Nothing run fuel (next x) run Dry _ = pure Nothing Service : Type -> Type Service a = Process a Ready Looping Client : Type -> Type Client a = Process a Ready Ready {- procAdder_bad1 : Process () Ready Looping procAdder_bad1 = do Action (putStrLn "I'm out of the office today") Loop procAdder_bad1 procAdder_bad2 : Process () Ready Looping procAdder_bad2 = Loop procAdder_bad2 -} procAdder : Service () procAdder = do Respond (\msg => case msg of Add x y => Pure (x + y)) Loop procAdder procMain : Client () procMain = do Just adder_id <- Spawn procAdder | Nothing => Action (putStrLn "Spawn failed") answer <- Request adder_id (Add 2 3) Action (printLn answer) partial runProc : Process () in_state out_state -> IO () runProc proc = do run forever proc pure () main : IO () main = runProc procMain ================================================ FILE: Chapter15/WordCount.idr ================================================ import ProcessLib record WCData where constructor MkWCData wordCount : Nat lineCount : Nat doCount : (content : String) -> WCData doCount content = let lcount = length (lines content) wcount = length (words content) in MkWCData lcount wcount data WC = CountFile String | GetData String WCType : WC -> Type WCType (CountFile x) = () WCType (GetData x) = Maybe WCData countFile : List (String, WCData) -> String -> Process WCType (List (String, WCData)) Sent Sent countFile files fname = do Right content <- Action (readFile fname) | Left err => Pure files let count = doCount content Action (putStrLn ("Counting complete for " ++ fname)) Pure ((fname, doCount content) :: files) total wcService : (loaded : List (String, WCData)) -> Service WCType () wcService loaded = do msg <- Respond (\msg => case msg of CountFile fname => Pure () GetData fname => Pure (lookup fname loaded)) newLoaded <- case msg of Just (CountFile fname) => countFile loaded fname _ => Pure loaded Loop (wcService newLoaded) procMain : Client () procMain = do Just wc <- Spawn (wcService []) | Nothing => Action (putStrLn "Spawn failed") Action (putStrLn "Counting test.txt") Request wc (CountFile "test.txt") Action (putStrLn "Processing") Just wcdata <- Request wc (GetData "test.txt") | Nothing => Action (putStrLn "File error") Action (putStrLn ("Words: " ++ show (wordCount wcdata))) Action (putStrLn ("Lines: " ++ show (lineCount wcdata))) partial main : IO () main = runProc procMain ================================================ FILE: Chapter15/test.txt ================================================ test test test test test test test ================================================ FILE: Chapter2/AveMain.idr ================================================ module Main import Average showAverage : String -> String showAverage str = "The average word length is: " ++ show (average str) ++ "\n" main : IO () main = repl "Enter a string: " showAverage ================================================ FILE: Chapter2/Average.idr ================================================ module Average ||| Calculate the average length of words in a string. ||| @str a string containing words separated by whitespace. export average : (str : String) -> Double average str = let numWords = wordCount str totalLength = sum (allLengths (words str)) in cast totalLength / cast numWords where wordCount : String -> Nat wordCount str = length (words str) allLengths : List String -> List Nat allLengths strs = map length strs ================================================ FILE: Chapter2/Double.idr ================================================ double : Int -> Int double x = x + x ================================================ FILE: Chapter2/Exercises/ex_2.idr ================================================ {- 1. (String, String, String) List String ((Char, String), Char) -} {- 2 -} palindrome : String -> Bool palindrome str = str == reverse str {- 3 -} palindrome_q3 : String -> Bool palindrome_q3 str = let strL = toLower str in strL == reverse strL {- 4 -} palindrome_q4 : String -> Bool palindrome_q4 str = if length str > 10 then palindrome_q3 str else False {- 5 -} palindrome_q5 : Nat -> String -> Bool palindrome_q5 min str = if length str > min then palindrome_q3 str else False {- 6 -} counts : String -> (Nat, Nat) counts str = (length (words str), length str) {- 7 -} top_ten : Ord a => List a -> List a top_ten xs = take 10 (reverse (sort xs)) {- 8 -} over_length : Nat -> List String -> Nat over_length num xs = let lengths = map length xs in length (filter (> num) lengths) ================================================ FILE: Chapter2/Exercises/ex_2_counts.idr ================================================ module Main counts : String -> (Nat, Nat) counts str = (length (words str), length str) main : IO () main = repl "Enter a string: " show_counts where show_counts : String -> String show_counts x = show (counts x) ++ "\n" ================================================ FILE: Chapter2/Exercises/ex_2_palindrome.idr ================================================ module Main palindrome : String -> Bool palindrome str = let strL = toLower str in strL == reverse strL main : IO () main = repl "Enter a string: " show_palindrome where show_palindrome : String -> String show_palindrome x = show (palindrome x) ++ "\n" ================================================ FILE: Chapter2/Generic.idr ================================================ identityInt : Int -> Int identityInt x = x identityString : String -> String identityString x = x identityBool : Bool -> Bool identityBool x = x identity : ty -> ty identity x = x doubleNat : Nat -> Nat doubleNat x = x * x doubleInteger : Integer -> Integer doubleInteger x = x * x double : Num ty => ty -> ty double x = x * x ================================================ FILE: Chapter2/HOF.idr ================================================ double : Num a => a -> a double x = x * x twice : (a -> a) -> a -> a twice f x = f (f x) Shape : Type rotate : Shape -> Shape quadruple : Num a => a -> a quadruple = twice double turn_around : Shape -> Shape turn_around = twice rotate ================================================ FILE: Chapter2/Let_Where.idr ================================================ longer : String -> String -> Nat longer word1 word2 = let len1 = length word1 len2 = length word2 in if len1 > len2 then len1 else len2 pythagoras : Double -> Double -> Double pythagoras x y = sqrt (square x + square y) where square : Double -> Double square x = x * x ================================================ FILE: Chapter2/Partial.idr ================================================ add : Int -> Int -> Int add x y = x + y ================================================ FILE: Chapter2/Reverse.idr ================================================ module Main main : IO () main = repl "> " reverse ================================================ FILE: Chapter3/Exercises/ex_3_2.idr ================================================ import Data.Vect {- 1 -} my_length : List a -> Nat my_length [] = 0 my_length (x :: xs) = 1 + my_length xs {- 2 -} my_reverse : List a -> List a my_reverse [] = [] my_reverse (x :: xs) = my_reverse xs ++ [x] {- 3 -} my_map : (a -> b) -> List a -> List b my_map f [] = [] my_map f (x :: xs) = f x :: my_map f xs {- 4 -} my_vect_map : (a -> b) -> Vect n a -> Vect n b my_vect_map f [] = [] my_vect_map f (x :: xs) = f x :: my_vect_map f xs ================================================ FILE: Chapter3/Exercises/ex_3_3.idr ================================================ import Data.Vect {- 1 -} create_empties : Vect n (Vect 0 elem) create_empties = replicate _ [] transpose_mat : Vect m (Vect n elem) -> Vect n (Vect m elem) transpose_mat [] = create_empties transpose_mat (x :: xs) = let xs_trans = transpose_mat xs in zipWith (::) x xs_trans {- 2 -} addMatrix : Num a => Vect n (Vect m a) -> Vect n (Vect m a) -> Vect n (Vect m a) addMatrix [] [] = [] addMatrix (x :: xs) (y :: ys) = zipWith (+) x y :: addMatrix xs ys {- 3 -} multVecs : Num a => (xs : Vect n a) -> (ys : Vect n a) -> a multVecs xs ys = sum (zipWith (*) xs ys) mkRow : Num a => (x : Vect n a) -> (ys_trans : Vect p (Vect n a)) -> Vect p a mkRow x [] = [] mkRow x (y :: xs) = multVecs x y :: mkRow x xs multMatrix_helper : Num a => (xs : Vect m (Vect n a)) -> (ys_trans : Vect p (Vect n a)) -> Vect m (Vect p a) multMatrix_helper [] ys_trans = [] multMatrix_helper (x :: xs) ys_trans = mkRow x ys_trans :: multMatrix_helper xs ys_trans multMatrix : Num a => Vect m (Vect n a) -> Vect n (Vect p a) -> Vect m (Vect p a) multMatrix xs ys = let ys_trans = transpose_mat ys in multMatrix_helper xs ys_trans ================================================ FILE: Chapter3/IsEven.idr ================================================ isEven' : Nat -> Bool isEven' Z = True isEven' (S k) = not (isEven' k) mutual isEven : Nat -> Bool isEven Z = True isEven (S k) = isOdd k isOdd : Nat -> Bool isOdd Z = False isOdd (S k) = isEven k ================================================ FILE: Chapter3/Matrix.idr ================================================ import Data.Vect createEmpties : Vect n (Vect 0 elem) createEmpties {n = Z} = [] createEmpties {n = (S k)} = [] :: createEmpties transposeHelper : (x : Vect n elem) -> (xs_trans : Vect n (Vect k elem)) -> Vect n (Vect (S k) elem) transposeHelper [] [] = [] transposeHelper (x :: xs) (y :: ys) = (x :: y) :: transposeHelper xs ys transposeMat : Vect m (Vect n elem) -> Vect n (Vect m elem) transposeMat [] = createEmpties transposeMat (x :: xs) = let xsTrans = transposeMat xs in transposeHelper x xsTrans ================================================ FILE: Chapter3/VecSort.idr ================================================ import Data.Vect insert : Ord elem => (x : elem) -> (xsSorted : Vect k elem) -> Vect (S k) elem insert x [] = [x] insert x (y :: xs) = case x < y of False => y :: insert x xs True => x :: y :: xs insSort : Ord elem => Vect n elem -> Vect n elem insSort [] = [] insSort (x :: xs) = let xsSorted = insSort xs in insert x xsSorted ================================================ FILE: Chapter3/Vectors.idr ================================================ import Data.Vect fourInts : Vect 4 Int fourInts = [0, 1, 2, 3] sixInts : Vect 6 Int sixInts = [4, 5, 6, 7, 8, 9] tenInts : Vect 10 Int tenInts = fourInts ++ sixInts ================================================ FILE: Chapter3/WordLength.idr ================================================ allLengths : List String -> List Nat allLengths [] = [] allLengths (word :: words) = length word :: allLengths words ================================================ FILE: Chapter3/WordLength_vec.idr ================================================ import Data.Vect total allLengths : Vect len String -> Vect len Nat allLengths [] = [] allLengths (word :: words) = length word :: allLengths words ================================================ FILE: Chapter3/XOR.idr ================================================ xor : Bool -> Bool -> Bool xor False y = y xor True y = not y ================================================ FILE: Chapter4/BSTree.idr ================================================ data BSTree : Type -> Type where Empty : Ord elem => BSTree elem Node : Ord elem => (left : BSTree elem) -> (val : elem) -> (right : BSTree elem) -> BSTree elem insert : elem -> BSTree elem -> BSTree elem insert x Empty = Node Empty x Empty insert x orig@(Node left val right) = case compare x val of LT => Node (insert x left) val right EQ => orig GT => Node left val (insert x right) ================================================ FILE: Chapter4/DataStore.idr ================================================ module Main import Data.Vect data DataStore : Type where MkData : (size : Nat) -> (items : Vect size String) -> DataStore size : DataStore -> Nat size (MkData size' items') = size' items : (store : DataStore) -> Vect (size store) String items (MkData size' items') = items' addToStore : DataStore -> String -> DataStore addToStore (MkData size store) newitem = MkData _ (addToData store) where addToData : Vect oldsize String -> Vect (S oldsize) String addToData [] = [newitem] addToData (x :: xs) = x :: addToData xs data Command = Add String | Get Integer | Quit parseCommand : String -> String -> Maybe Command parseCommand "add" str = Just (Add str) parseCommand "get" val = case all isDigit (unpack val) of False => Nothing True => Just (Get (cast val)) parseCommand "quit" "" = Just Quit parseCommand _ _ = Nothing parse : (input : String) -> Maybe Command parse input = case span (/= ' ') input of (cmd, args) => parseCommand cmd (ltrim args) getEntry : (pos : Integer) -> (store : DataStore) -> Maybe (String, DataStore) getEntry pos store = let store_items = items store in case integerToFin pos (size store) of Nothing => Just ("Out of range\n", store) Just id => Just (index id store_items ++ "\n", store) processInput : DataStore -> String -> Maybe (String, DataStore) processInput store input = case parse input of Nothing => Just ("Invalid command\n", store) Just (Add item) => Just ("ID " ++ show (size store) ++ "\n", addToStore store item) Just (Get pos) => getEntry pos store Just Quit => Nothing main : IO () main = replWith (MkData _ []) "Command: " processInput ================================================ FILE: Chapter4/Direction.idr ================================================ data Direction = North | East | South | West turnClockwise : Direction -> Direction turnClockwise North = East turnClockwise East = South turnClockwise South = West turnClockwise West = North ================================================ FILE: Chapter4/Exercises/ex_4_1.idr ================================================ {- Support code -} data Shape = ||| A triangle, with its base length and height Triangle Double Double | ||| A rectangle, with its length and height Rectangle Double Double | ||| A circle, with its radius Circle Double area : Shape -> Double area (Triangle base height) = 0.5 * base * height area (Rectangle length height) = length * height area (Circle radius) = pi * radius * radius data Picture = Primitive Shape | Combine Picture Picture | Rotate Double Picture | Translate Double Double Picture testPic1 : Picture testPic1 = Combine (Primitive (Triangle 2 3)) (Primitive (Triangle 2 4)) testPic2 : Picture testPic2 = Combine (Primitive (Rectangle 1 3)) (Primitive (Circle 4)) data Tree elem = Empty | Node (Tree elem) elem (Tree elem) %name Tree tree, tree1 insert : Ord elem => elem -> Tree elem -> Tree elem insert x Empty = Node Empty x Empty insert x orig@(Node left val right) = case compare x val of LT => Node (insert x left) val right EQ => orig GT => Node left val (insert x right) {- Answers -} {- 1 -} listToTree : Ord a => List a -> Tree a listToTree [] = Empty listToTree (x :: xs) = insert x (listToTree xs) {- 2 -} treeToList : Tree a -> List a treeToList Empty = [] treeToList (Node left val right) = treeToList left ++ val :: treeToList right {- 3 -} data Expr = Val Int | Add Expr Expr | Sub Expr Expr | Mult Expr Expr {- 4 -} evaluate : Expr -> Int evaluate (Val x) = x evaluate (Add x y) = evaluate x + evaluate y evaluate (Sub x y) = evaluate x - evaluate y evaluate (Mult x y) = evaluate x * evaluate y {- 5 -} maxMaybe : Ord a => Maybe a -> Maybe a -> Maybe a maxMaybe Nothing Nothing = Nothing maxMaybe Nothing (Just x) = Just x maxMaybe (Just x) Nothing = Just x maxMaybe (Just x) (Just y) = Just (max x y) {- 6 -} biggestTriangle : Picture -> Maybe Double biggestTriangle (Primitive tri@(Triangle x y)) = Just (area tri) biggestTriangle (Primitive _) = Nothing biggestTriangle (Combine x y) = maxMaybe (biggestTriangle x) (biggestTriangle y) biggestTriangle (Rotate x pic) = biggestTriangle pic biggestTriangle (Translate x y pic) = biggestTriangle pic ================================================ FILE: Chapter4/Exercises/ex_4_2.idr ================================================ {- 1 -} data PowerSource = Petrol | Pedal data Vehicle : PowerSource -> Type where Bicycle : Vehicle Pedal Unicycle : Vehicle Pedal Motorcycle : (fuel : Nat) -> Vehicle Petrol Car : (fuel : Nat) -> Vehicle Petrol Bus : (fuel : Nat) -> Vehicle Petrol wheels : Vehicle power -> Nat wheels Bicycle = 2 wheels Unicycle = 1 wheels (Motorcycle fuel) = 2 wheels (Car fuel) = 4 wheels (Bus fuel) = 4 refuel : Vehicle Petrol -> Vehicle Petrol refuel (Car fuel) = Car 100 refuel (Bus fuel) = Bus 200 refuel (Motorcycle fuel) = Motorcycle 50 ================================================ FILE: Chapter4/Exercises/ex_4_2_1.idr ================================================ {- 1 -} data PowerSource = Petrol | Pedal data Vehicle : PowerSource -> Type where Bicycle : Vehicle Pedal Unicycle : Vehicle Pedal Motorcycle : (fuel : Nat) -> Vehicle Petrol Car : (fuel : Nat) -> Vehicle Petrol Bus : (fuel : Nat) -> Vehicle Petrol wheels : Vehicle power -> Nat wheels Bicycle = 2 wheels Unicycle = 1 wheels (Motorcycle fuel) = 2 wheels (Car fuel) = 4 wheels (Bus fuel) = 4 refuel : Vehicle Petrol -> Vehicle Petrol refuel (Car fuel) = Car 100 refuel (Bus fuel) = Bus 200 refuel (Motorcycle fuel) = Motorcycle 50 ================================================ FILE: Chapter4/Exercises/ex_4_2_2.idr ================================================ {- 2 -} data PowerSource = Petrol | Pedal | Electric data Vehicle : PowerSource -> Type where Bicycle : Vehicle Pedal Unicycle : Vehicle Pedal Motorcycle : (fuel : Nat) -> Vehicle Petrol Car : (fuel : Nat) -> Vehicle Petrol Bus : (fuel : Nat) -> Vehicle Petrol Tram : Vehicle Electric wheels : Vehicle power -> Nat wheels Bicycle = 2 wheels Unicycle = 1 wheels (Motorcycle fuel) = 2 wheels (Car fuel) = 4 wheels (Bus fuel) = 4 wheels Tram = 8 refuel : Vehicle Petrol -> Vehicle Petrol refuel (Car fuel) = Car 100 refuel (Bus fuel) = Bus 200 refuel (Motorcycle fuel) = Motorcycle 50 ================================================ FILE: Chapter4/Exercises/ex_4_2_3.idr ================================================ data Vect : Nat -> Type -> Type where Nil : Vect Z a (::) : (x : a) -> (xs : Vect k a) -> Vect (S k) a %name Vect xs, ys, zs {- 3 and 4-} vectTake : (n : Nat) -> Vect (n + m) a -> Vect n a vectTake Z xs = [] vectTake (S k) (x :: xs) = x :: vectTake k xs ================================================ FILE: Chapter4/Exercises/ex_4_2_5.idr ================================================ import Data.Vect {- 5 -} sumEntries : Num a => (pos : Integer) -> Vect n a -> Vect n a -> Maybe a sumEntries {n} pos xs ys = case integerToFin pos n of Nothing => Nothing Just idx => Just (index idx xs + index idx ys) ================================================ FILE: Chapter4/Exercises/ex_4_3.idr ================================================ module Main import Data.Vect data DataStore : Type where MkData : (size : Nat) -> (items : Vect size String) -> DataStore size : DataStore -> Nat size (MkData size' items') = size' items : (store : DataStore) -> Vect (size store) String items (MkData size' items') = items' addToStore : DataStore -> String -> DataStore addToStore (MkData size store) newitem = MkData _ (addToData store) where addToData : Vect oldsize String -> Vect (S oldsize) String addToData [] = [newitem] addToData (x :: xs) = x :: addToData xs data Command = Add String | Get Integer | Size {- question 1 -} | Search String {- question 2 -} | Quit parseCommand : List String -> Maybe Command parseCommand ("add" :: rest) = Just (Add (unwords rest)) parseCommand ["get", val] = case all isDigit (unpack val) of False => Nothing True => Just (Get (cast val)) parseCommand ["quit"] = Just Quit parseCommand ["size"] = Just Size {- question 1 -} parseCommand ("search" :: rest) = Just (Search (unwords rest)) {- question 2 -} parseCommand _ = Nothing parse : (input : String) -> Maybe Command parse input = parseCommand (words input) getEntry : (pos : Integer) -> (store : DataStore) -> Maybe (String, DataStore) getEntry pos store = let store_items = items store in case integerToFin pos (size store) of Nothing => Just ("Out of range\n", store) Just id => Just (index id (items store) ++ "\n", store) {- question 2/3 -} searchString : Nat -> (items : Vect n String) -> (str : String) -> String searchString idx [] str = "" searchString idx (x :: xs) str = let rest = searchString (idx + 1) xs str in if isInfixOf str x then show idx ++ ": " ++ x ++ "\n" ++ rest else rest processInput : DataStore -> String -> Maybe (String, DataStore) processInput store input = case parse input of Nothing => Just ("Invalid command\n", store) Just (Add item) => Just ("ID " ++ show (size store) ++ "\n", addToStore store item) Just (Get pos) => getEntry pos store Just Size => Just (show (size store) ++ "\n", store) {- question 1 -} Just (Search str) => Just (searchString 0 (items store) str, store) {- question 2 -} Just Quit => Nothing main : IO () main = replWith (MkData _ []) "Command: " processInput ================================================ FILE: Chapter4/Generic.idr ================================================ safeDivide : Double -> Double -> Maybe Double safeDivide x y = if y == 0 then Nothing else Just (x / y) ================================================ FILE: Chapter4/Picture.idr ================================================ data Shape = ||| A triangle, with its base length and height Triangle Double Double | ||| A rectangle, with its length and height Rectangle Double Double | ||| A circle, with its radius Circle Double area : Shape -> Double area (Triangle base height) = 0.5 * base * height area (Rectangle length height) = length * height area (Circle radius) = pi * radius * radius data Picture = Primitive Shape | Combine Picture Picture | Rotate Double Picture | Translate Double Double Picture rectangle : Picture rectangle = Primitive (Rectangle 20 10) circle : Picture circle = Primitive (Circle 5) triangle : Picture triangle = Primitive (Triangle 10 10) testPicture : Picture testPicture = Combine (Translate 5 5 rectangle) (Combine (Translate 35 5 circle) (Translate 15 25 triangle)) pictureArea : Picture -> Double pictureArea (Primitive shape) = area shape pictureArea (Combine pic pic1) = pictureArea pic + pictureArea pic1 pictureArea (Rotate x pic) = pictureArea pic pictureArea (Translate x y pic) = pictureArea pic ================================================ FILE: Chapter4/Shape.idr ================================================ data Shape = ||| A triangle, with its base length and height Triangle Double Double | ||| A rectangle, with its length and height Rectangle Double Double | ||| A circle, with its radius Circle Double area : Shape -> Double area (Triangle base height) = 0.5 * base * height area (Rectangle length height) = length * height area (Circle radius) = pi * radius * radius ================================================ FILE: Chapter4/SumInputs.idr ================================================ sumInputs : Integer -> String -> Maybe (String, Integer) sumInputs tot inp = let val = cast inp in if val < 0 then Nothing else let newVal = tot + val in Just ("Subtotal: " ++ show newVal ++ "\n", newVal) main : IO () main = replWith 0 "Value: " sumInputs ================================================ FILE: Chapter4/Tree.idr ================================================ data Tree elem = Empty | Node (Tree elem) elem (Tree elem) %name Tree tree, tree1 insert : Ord elem => elem -> Tree elem -> Tree elem insert x Empty = Node Empty x Empty insert x orig@(Node left val right) = case compare x val of LT => Node (insert x left) val right EQ => orig GT => Node left val (insert x right) ================================================ FILE: Chapter4/TryIndex.idr ================================================ import Data.Vect tryIndex : Integer -> Vect n a -> Maybe a tryIndex {n} i xs = case integerToFin i n of Nothing => Nothing Just idx => Just (index idx xs) ================================================ FILE: Chapter4/Vect.idr ================================================ data Vect : Nat -> Type -> Type where Nil : Vect Z a (::) : (x : a) -> (xs : Vect k a) -> Vect (S k) a %name Vect xs, ys, zs append : Vect n elem -> Vect m elem -> Vect (n + m) elem append [] ys = ys append (x :: xs) ys = x :: append xs ys zip : Vect n a -> Vect n b -> Vect n (a, b) zip [] [] = [] zip (x :: xs) (y :: ys) = (x, y) :: zip xs ys ================================================ FILE: Chapter4/Vehicle.idr ================================================ data PowerSource = Petrol | Pedal data Vehicle : PowerSource -> Type where Bicycle : Vehicle Pedal Car : (fuel : Nat) -> Vehicle Petrol Bus : (fuel : Nat) -> Vehicle Petrol wheels : Vehicle power -> Nat wheels Bicycle = 2 wheels (Car fuel) = 4 wheels (Bus fuel) = 4 refuel : Vehicle Petrol -> Vehicle Petrol refuel (Car fuel) = Car 100 refuel (Bus fuel) = Bus 200 refuel Bicycle impossible ================================================ FILE: Chapter5/DepPairs.idr ================================================ import Data.Vect anyVect : (n ** Vect n String) anyVect = (3 ** ["Rod", "Jane", "Freddy"]) readVect : IO (len ** Vect len String) readVect = do x <- getLine if (x == "") then pure (_ ** []) else do (_ ** xs) <- readVect pure (_ ** x :: xs) zipInputs : IO () zipInputs = do putStrLn "Enter first vector (blank line to end):" (len1 ** vec1) <- readVect putStrLn "Enter second vector (blank line to end):" (len2 ** vec2) <- readVect case exactLength len1 vec2 of Nothing => putStrLn "Vectors are different lengths" Just vec2' => printLn (zip vec1 vec2') ================================================ FILE: Chapter5/Do.idr ================================================ printTwoThings : IO () printTwoThings = do putStrLn "Hello" putStrLn "World" printInput : IO () printInput = do x <- getLine putStrLn x printLength : IO () printLength = do putStr "Input string: " input <- getLine let len = length input putStrLn (show len) ================================================ FILE: Chapter5/Exercises/ex_5_1.idr ================================================ {- 1 -} printLonger : IO () printLonger = do putStr "First string: " str1 <- getLine putStr "Second string: " str2 <- getLine if length str1 > length str2 then putStrLn (show (length str1)) else putStrLn (show (length str2)) {- 2 -} printLonger' : IO () printLonger' = putStr "First string: " >>= \_ => getLine >>= \str1 => putStr "Second string: " >>= \_ => getLine >>= \str2 => if length str1 > length str2 then putStrLn (show (length str1)) else putStrLn (show (length str2)) ================================================ FILE: Chapter5/Exercises/ex_5_2_1.idr ================================================ import System {- 1 -} readNumber : IO (Maybe Nat) readNumber = do input <- getLine if all isDigit (unpack input) then pure (Just (cast input)) else pure Nothing guess : (answer : Nat) -> IO () guess answer = do putStr ("Guess a number between 1 and 100: ") isNum <- readNumber case isNum of Nothing => do putStrLn "Invalid input" guess answer Just userguess => if userguess < answer then do putStrLn "Too low" guess answer else if userguess > answer then do putStrLn "Too high" guess answer else putStrLn "Well done!" {- 2 -} main : IO () main = do t <- time guess (cast (t `mod` 101)) ================================================ FILE: Chapter5/Exercises/ex_5_2_3.idr ================================================ import System {- 3 -} readNumber : IO (Maybe Nat) readNumber = do input <- getLine if all isDigit (unpack input) then pure (Just (cast input)) else pure Nothing guess : (target : Nat) -> (guesses : Nat) -> IO () guess target guesses = do putStrLn (show guesses ++ " guesses so far") putStr ("Guess a number between 1 and 100: ") isNum <- readNumber case isNum of Nothing => do putStrLn "Invalid input" guess target guesses Just userguess => if userguess < target then do putStrLn "Too low" guess target (guesses + 1) else if userguess > target then do putStrLn "Too high" guess target (guesses + 1) else putStrLn "Well done!" main : IO () main = do t <- time guess (cast (t `mod` 101)) 0 ================================================ FILE: Chapter5/Exercises/ex_5_2_4.idr ================================================ {- 4 -} my_repl : (prompt : String) -> (fn : String -> String) -> IO () my_repl prompt fn = do putStr prompt x <- getLine putStr (fn x) my_repl prompt fn my_replWith : (state : a) -> (prompt : String) -> (fn : a -> String -> Maybe (String, a)) -> IO () my_replWith acc prompt fn = do putStr prompt x <- getLine case fn acc x of Just (out, acc') => do putStr out my_replWith acc' prompt fn Nothing => pure () ================================================ FILE: Chapter5/Exercises/ex_5_3.idr ================================================ import Data.Vect {- 1 -} readToBlank : IO (List String) readToBlank = do x <- getLine case x of "" => pure [] _ => do rest <- readToBlank pure (x :: rest) {- 2 -} readAndSave : IO () readAndSave = do lines <- readToBlank putStr "Filename: " f <- getLine Right () <- writeFile f (unlines lines) | Left err => putStrLn (show err) pure () {- 3 -} readVectFile : (filename : String) -> IO (n ** Vect n String) readVectFile filename = do Right h <- openFile filename Read | Left err => pure (_ ** []) Right contents <- readContents h | Left err => pure (_ ** []) closeFile h pure contents where readContents : File -> IO (Either FileError (n ** Vect n String)) readContents h = do eof <- fEOF h if eof then pure (Right (_ ** [])) else do Right str <- fGetLine h | Left err => pure (Left err) Right (_ ** rest) <- readContents h | Left err => pure (Left err) pure (Right (_ ** str :: rest)) ================================================ FILE: Chapter5/Hello.idr ================================================ module Main main : IO () main = do putStr "Enter your name: " x <- getLine putStrLn ("Hello " ++ x ++ "!") ================================================ FILE: Chapter5/Loops.idr ================================================ module Main import System countdown : (secs : Nat) -> IO () countdown Z = putStrLn "Lift off!" countdown (S secs) = do putStrLn (show (S secs)) usleep 1000000 countdown secs readNumber : IO (Maybe Nat) readNumber = do input <- getLine if all isDigit (unpack input) then pure (Just (cast input)) else pure Nothing countdowns : IO () countdowns = do putStr "Enter starting number: " Just startNum <- readNumber | Nothing => do putStrLn "Invalid input" countdowns countdown startNum putStr "Another (y/n)? " yn <- getLine if yn == "y" then countdowns else pure () ================================================ FILE: Chapter5/PrintLength.idr ================================================ printLength : IO () printLength = putStr "Input string: " >>= \_ => getLine >>= \input => let len = length input in putStrLn (show len) ================================================ FILE: Chapter5/ReadNum.idr ================================================ readNumber : IO (Maybe Nat) readNumber = do input <- getLine if all isDigit (unpack input) then pure (Just (cast input)) else pure Nothing readNumbers_v1 : IO (Maybe (Nat, Nat)) readNumbers_v1 = do num1 <- readNumber case num1 of Nothing => pure Nothing Just num1_ok => do num2 <- readNumber case num2 of Nothing => pure Nothing Just num2_ok => pure (Just (num1_ok, num2_ok)) readPair : IO (String, String) readPair = do str1 <- getLine str2 <- getLine pure (str1, str2) readNumbers_v2 : IO (Maybe (Nat, Nat)) readNumbers_v2 = do Just num1_ok <- readNumber Just num2_ok <- readNumber pure (Just (num1_ok, num2_ok)) readNumbers : IO (Maybe (Nat, Nat)) readNumbers = do Just num1_ok <- readNumber | Nothing => pure Nothing Just num2_ok <- readNumber | Nothing => pure Nothing pure (Just (num1_ok, num2_ok)) ================================================ FILE: Chapter5/ReadVect.idr ================================================ import Data.Vect readVectLen : (len : Nat) -> IO (Vect len String) readVectLen Z = pure [] readVectLen (S k) = do x <- getLine xs <- readVectLen k pure (x :: xs) data VectUnknown : Type -> Type where MkVect : (len : Nat) -> Vect len a -> VectUnknown a readVect : IO (VectUnknown String) readVect = do x <- getLine if (x == "") then pure (MkVect _ []) else do MkVect _ xs <- readVect pure (MkVect _ (x :: xs)) printVect : Show a => VectUnknown a -> IO () printVect (MkVect len xs) = putStrLn (show xs ++ " (length " ++ show len ++ ")") ================================================ FILE: Chapter6/Adder.idr ================================================ AdderType : (numargs : Nat) -> Type -> Type AdderType Z numType = numType AdderType (S k) numType = (next : numType) -> AdderType k numType adder : Num numType => (numargs : Nat) -> numType -> AdderType numargs numType adder Z acc = acc adder (S k) acc = \next => adder k (next + acc) ================================================ FILE: Chapter6/DataStore.idr ================================================ module Main import Data.Vect infixr 5 .+. data Schema = SString | SInt | (.+.) Schema Schema SchemaType : Schema -> Type SchemaType SString = String SchemaType SInt = Int SchemaType (x .+. y) = (SchemaType x, SchemaType y) record DataStore where constructor MkData schema : Schema size : Nat items : Vect size (SchemaType schema) addToStore : (store : DataStore) -> SchemaType (schema store) -> DataStore addToStore (MkData schema size store) newitem = MkData schema _ (addToData store) where addToData : Vect oldsize (SchemaType schema) -> Vect (S oldsize) (SchemaType schema) addToData [] = [newitem] addToData (x :: xs) = x :: addToData xs setSchema : (store : DataStore) -> Schema -> Maybe DataStore setSchema store schema = case size store of Z => Just (MkData schema _ []) S k => Nothing data Command : Schema -> Type where SetSchema : Schema -> Command schema Add : SchemaType schema -> Command schema Get : Integer -> Command schema Quit : Command schema parsePrefix : (schema : Schema) -> String -> Maybe (SchemaType schema, String) parsePrefix SString input = getQuoted (unpack input) where getQuoted : List Char -> Maybe (String, String) getQuoted ('"' :: xs) = case span (/= '"') xs of (quoted, '"' :: rest) => Just (pack quoted, ltrim (pack rest)) _ => Nothing getQuoted _ = Nothing parsePrefix SInt input = case span isDigit input of ("", rest) => Nothing (num, rest) => Just (cast num, ltrim rest) parsePrefix (schemal .+. schemar) input = case parsePrefix schemal input of Nothing => Nothing Just (l_val, input') => case parsePrefix schemar input' of Nothing => Nothing Just (r_val, input'') => Just ((l_val, r_val), input'') parseBySchema : (schema : Schema) -> String -> Maybe (SchemaType schema) parseBySchema schema x = case parsePrefix schema x of Nothing => Nothing Just (res, "") => Just res Just _ => Nothing parseSchema : List String -> Maybe Schema parseSchema ("String" :: xs) = case xs of [] => Just SString _ => case parseSchema xs of Nothing => Nothing Just xs_sch => Just (SString .+. xs_sch) parseSchema ("Int" :: xs) = case xs of [] => Just SInt _ => case parseSchema xs of Nothing => Nothing Just xs_sch => Just (SInt .+. xs_sch) parseSchema _ = Nothing parseCommand : (schema : Schema) -> String -> String -> Maybe (Command schema) parseCommand schema "add" rest = case parseBySchema schema rest of Nothing => Nothing Just restok => Just (Add restok) parseCommand schema "get" val = case all isDigit (unpack val) of False => Nothing True => Just (Get (cast val)) parseCommand schema "quit" "" = Just Quit parseCommand schema "schema" rest = case parseSchema (words rest) of Nothing => Nothing Just schemaok => Just (SetSchema schemaok) parseCommand _ _ _ = Nothing parse : (schema : Schema) -> (input : String) -> Maybe (Command schema) parse schema input = case span (/= ' ') input of (cmd, args) => parseCommand schema cmd (ltrim args) display : SchemaType schema -> String display {schema = SString} item = show item display {schema = SInt} item = show item display {schema = (y .+. z)} (iteml, itemr) = display iteml ++ ", " ++ display itemr getEntry : (pos : Integer) -> (store : DataStore) -> Maybe (String, DataStore) getEntry pos store = let store_items = items store in case integerToFin pos (size store) of Nothing => Just ("Out of range\n", store) Just id => Just (display (index id (items store)) ++ "\n", store) processInput : DataStore -> String -> Maybe (String, DataStore) processInput store input = case parse (schema store) input of Nothing => Just ("Invalid command\n", store) Just (Add item) => Just ("ID " ++ show (size store) ++ "\n", addToStore store item) Just (SetSchema schema') => case setSchema store schema' of Nothing => Just ("Can't update schema when entries in store\n", store) Just store' => Just ("OK\n", store') Just (Get pos) => getEntry pos store Just Quit => Nothing main : IO () main = replWith (MkData (SString .+. SString .+. SInt) _ []) "Command: " processInput ================================================ FILE: Chapter6/DataStoreHoles.idr ================================================ module Main import Data.Vect infixr 5 .+. data Schema = SString | SInt | (.+.) Schema Schema SchemaType : Schema -> Type SchemaType SString = String SchemaType SInt = Int SchemaType (x .+. y) = (SchemaType x, SchemaType y) record DataStore where constructor MkData schema : Schema size : Nat items : Vect size (SchemaType schema) addToStore : (d : DataStore) -> SchemaType (schema d) -> DataStore addToStore (MkData schema size store) newitem = MkData schema _ (addToData store) where addToData : Vect oldsize (SchemaType schema) -> Vect (S oldsize) (SchemaType schema) addToData [] = [newitem] addToData (x :: xs) = x :: addToData xs data Command : Schema -> Type where Add : SchemaType schema -> Command schema Get : Integer -> Command schema Quit : Command schema parseCommand : String -> String -> Maybe (Command schema) parseCommand "add" rest = Just (Add (?parseBySchema rest)) parseCommand "get" val = case all isDigit (unpack val) of False => Nothing True => Just (Get (cast val)) parseCommand "quit" "" = Just Quit parseCommand _ _ = Nothing parse : (schema : Schema) -> (input : String) -> Maybe (Command schema) parse schema input = case span (/= ' ') input of (cmd, args) => parseCommand cmd (ltrim args) getEntry : (pos : Integer) -> (store : DataStore) -> Maybe (String, DataStore) getEntry pos store = let store_items = items store in case integerToFin pos (size store) of Nothing => Just ("Out of range\n", store) Just id => Just (?display (index id (items store)) ++ "\n", store) processInput : DataStore -> String -> Maybe (String, DataStore) processInput store input = case parse (schema store) input of Nothing => Just ("Invalid command\n", store) Just (Add item) => Just ("ID " ++ show (size store) ++ "\n", addToStore store item) Just (Get pos) => getEntry pos store Just Quit => Nothing main : IO () main = replWith (MkData SString _ []) "Command: " processInput ================================================ FILE: Chapter6/Exercises/ex_6_2_1.idr ================================================ import Data.Vect {- 1 -} Matrix : Nat -> Nat -> Type Matrix n m = Vect n (Vect m Double) testMatrix : Matrix 2 3 testMatrix = [[0, 0, 0], [0, 0, 0]] ================================================ FILE: Chapter6/Exercises/ex_6_2_2.idr ================================================ data Format = Number Format | Str Format | Lit String Format | Ch Format | Dbl Format | End PrintfType : Format -> Type PrintfType (Number fmt) = (i : Int) -> PrintfType fmt PrintfType (Str fmt) = (str : String) -> PrintfType fmt PrintfType (Lit str fmt) = PrintfType fmt PrintfType (Ch fmt) = (c : Char) -> PrintfType fmt PrintfType (Dbl fmt) = (d : Double) -> PrintfType fmt PrintfType End = String printfFmt : (fmt : Format) -> (acc : String) -> PrintfType fmt printfFmt (Number fmt) acc = \i => printfFmt fmt (acc ++ show i) printfFmt (Str fmt) acc = \str => printfFmt fmt (acc ++ str) printfFmt (Ch fmt) acc = \c => printfFmt fmt (acc ++ show c) printfFmt (Dbl fmt) acc = \d => printfFmt fmt (acc ++ show d) printfFmt (Lit lit fmt) acc = printfFmt fmt (acc ++ lit) printfFmt End acc = acc toFormat : (xs : List Char) -> Format toFormat [] = End toFormat ('%' :: 'd' :: chars) = Number (toFormat chars) toFormat ('%' :: 's' :: chars) = Str (toFormat chars) toFormat ('%' :: 'c' :: chars) = Ch (toFormat chars) toFormat ('%' :: 'f' :: chars) = Dbl (toFormat chars) toFormat ('%' :: chars) = Lit "%" (toFormat chars) toFormat (c :: chars) = case toFormat chars of Lit lit chars' => Lit (strCons c lit) chars' fmt => Lit (strCons c "") fmt printf : (fmt : String) -> PrintfType (toFormat (unpack fmt)) printf fmt = printfFmt _ "" ================================================ FILE: Chapter6/Exercises/ex_6_2_3.idr ================================================ TupleVect : Nat -> Type -> Type TupleVect Z ty = () TupleVect (S k) ty = (ty, TupleVect k ty) test : TupleVect 4 Nat test = (1,2,3,4,()) ================================================ FILE: Chapter6/Exercises/ex_6_3_1.idr ================================================ module Main import Data.Vect infixr 5 .+. data Schema = SString | SInt | SChar | (.+.) Schema Schema SchemaType : Schema -> Type SchemaType SString = String SchemaType SInt = Int SchemaType SChar = Char SchemaType (x .+. y) = (SchemaType x, SchemaType y) record DataStore where constructor MkData schema : Schema size : Nat items : Vect size (SchemaType schema) addToStore : (store : DataStore) -> SchemaType (schema store) -> DataStore addToStore (MkData schema size store) newitem = MkData schema _ (addToData store) where addToData : Vect oldsize (SchemaType schema) -> Vect (S oldsize) (SchemaType schema) addToData [] = [newitem] addToData (x :: xs) = x :: addToData xs setSchema : (store : DataStore) -> Schema -> Maybe DataStore setSchema store schema = case size store of Z => Just (MkData schema _ []) S k => Nothing data Command : Schema -> Type where SetSchema : Schema -> Command schema Add : SchemaType schema -> Command schema Get : Integer -> Command schema Quit : Command schema parsePrefix : (schema : Schema) -> String -> Maybe (SchemaType schema, String) parsePrefix SString input = getQuoted (unpack input) where getQuoted : List Char -> Maybe (String, String) getQuoted ('"' :: xs) = case span (/= '"') xs of (quoted, '"' :: rest) => Just (pack quoted, ltrim (pack rest)) _ => Nothing getQuoted _ = Nothing parsePrefix SInt input = case span isDigit input of ("", rest) => Nothing (num, rest) => Just (cast num, ltrim rest) parsePrefix SChar input = case unpack input of (c :: cs) => Just (c, ltrim (pack cs)) [] => Nothing parsePrefix (schemal .+. schemar) input = case parsePrefix schemal input of Nothing => Nothing Just (l_val, input') => case parsePrefix schemar input' of Nothing => Nothing Just (r_val, input'') => Just ((l_val, r_val), input'') parseBySchema : (schema : Schema) -> String -> Maybe (SchemaType schema) parseBySchema schema x = case parsePrefix schema x of Nothing => Nothing Just (res, "") => Just res Just _ => Nothing parseSchema : List String -> Maybe Schema parseSchema ("String" :: xs) = case xs of [] => Just SString _ => case parseSchema xs of Nothing => Nothing Just xs_sch => Just (SString .+. xs_sch) parseSchema ("Int" :: xs) = case xs of [] => Just SInt _ => case parseSchema xs of Nothing => Nothing Just xs_sch => Just (SInt .+. xs_sch) parseSchema ("Char" :: xs) = case xs of [] => Just SInt _ => case parseSchema xs of Nothing => Nothing Just xs_sch => Just (SChar .+. xs_sch) parseSchema _ = Nothing parseCommand : (schema : Schema) -> String -> String -> Maybe (Command schema) parseCommand schema "add" rest = case parseBySchema schema rest of Nothing => Nothing Just restok => Just (Add restok) parseCommand schema "get" val = case all isDigit (unpack val) of False => Nothing True => Just (Get (cast val)) parseCommand schema "quit" "" = Just Quit parseCommand schema "schema" rest = case parseSchema (words rest) of Nothing => Nothing Just schemaok => Just (SetSchema schemaok) parseCommand _ _ _ = Nothing parse : (schema : Schema) -> (input : String) -> Maybe (Command schema) parse schema input = case span (/= ' ') input of (cmd, args) => parseCommand schema cmd (ltrim args) display : SchemaType schema -> String display {schema = SString} item = show item display {schema = SInt} item = show item display {schema = SChar} item = show item display {schema = (y .+. z)} (iteml, itemr) = display iteml ++ ", " ++ display itemr getEntry : (pos : Integer) -> (store : DataStore) -> Maybe (String, DataStore) getEntry pos store = let store_items = items store in case integerToFin pos (size store) of Nothing => Just ("Out of range\n", store) Just id => Just (display (index id (items store)) ++ "\n", store) processInput : DataStore -> String -> Maybe (String, DataStore) processInput store input = case parse (schema store) input of Nothing => Just ("Invalid command\n", store) Just (Add item) => Just ("ID " ++ show (size store) ++ "\n", addToStore store item) Just (SetSchema schema') => case setSchema store schema' of Nothing => Just ("Can't update schema when entries in store\n", store) Just store' => Just ("OK\n", store') Just (Get pos) => getEntry pos store Just Quit => Nothing main : IO () main = replWith (MkData (SString .+. SString .+. SInt) _ []) "Command: " processInput ================================================ FILE: Chapter6/Exercises/ex_6_3_2.idr ================================================ module Main import Data.Vect infixr 5 .+. data Schema = SString | SInt | SChar | (.+.) Schema Schema SchemaType : Schema -> Type SchemaType SString = String SchemaType SInt = Int SchemaType SChar = Char SchemaType (x .+. y) = (SchemaType x, SchemaType y) record DataStore where constructor MkData schema : Schema size : Nat items : Vect size (SchemaType schema) addToStore : (store : DataStore) -> SchemaType (schema store) -> DataStore addToStore (MkData schema size store) newitem = MkData schema _ (addToData store) where addToData : Vect oldsize (SchemaType schema) -> Vect (S oldsize) (SchemaType schema) addToData [] = [newitem] addToData (x :: xs) = x :: addToData xs setSchema : (store : DataStore) -> Schema -> Maybe DataStore setSchema store schema = case size store of Z => Just (MkData schema _ []) S k => Nothing data Command : Schema -> Type where SetSchema : Schema -> Command schema Add : SchemaType schema -> Command schema Get : Maybe Integer -> Command schema Quit : Command schema parsePrefix : (schema : Schema) -> String -> Maybe (SchemaType schema, String) parsePrefix SString input = getQuoted (unpack input) where getQuoted : List Char -> Maybe (String, String) getQuoted ('"' :: xs) = case span (/= '"') xs of (quoted, '"' :: rest) => Just (pack quoted, ltrim (pack rest)) _ => Nothing getQuoted _ = Nothing parsePrefix SInt input = case span isDigit input of ("", rest) => Nothing (num, rest) => Just (cast num, ltrim rest) parsePrefix SChar input = case unpack input of (c :: cs) => Just (c, ltrim (pack cs)) [] => Nothing parsePrefix (schemal .+. schemar) input = case parsePrefix schemal input of Nothing => Nothing Just (l_val, input') => case parsePrefix schemar input' of Nothing => Nothing Just (r_val, input'') => Just ((l_val, r_val), input'') parseBySchema : (schema : Schema) -> String -> Maybe (SchemaType schema) parseBySchema schema x = case parsePrefix schema x of Nothing => Nothing Just (res, "") => Just res Just _ => Nothing parseSchema : List String -> Maybe Schema parseSchema ("String" :: xs) = case xs of [] => Just SString _ => case parseSchema xs of Nothing => Nothing Just xs_sch => Just (SString .+. xs_sch) parseSchema ("Int" :: xs) = case xs of [] => Just SInt _ => case parseSchema xs of Nothing => Nothing Just xs_sch => Just (SInt .+. xs_sch) parseSchema ("Char" :: xs) = case xs of [] => Just SInt _ => case parseSchema xs of Nothing => Nothing Just xs_sch => Just (SChar .+. xs_sch) parseSchema _ = Nothing parseCommand : (schema : Schema) -> String -> String -> Maybe (Command schema) parseCommand schema "add" rest = case parseBySchema schema rest of Nothing => Nothing Just restok => Just (Add restok) parseCommand schema "get" "" = Just (Get Nothing) parseCommand schema "get" val = case all isDigit (unpack val) of False => Nothing True => Just (Get (Just (cast val))) parseCommand schema "quit" "" = Just Quit parseCommand schema "schema" rest = case parseSchema (words rest) of Nothing => Nothing Just schemaok => Just (SetSchema schemaok) parseCommand _ _ _ = Nothing parse : (schema : Schema) -> (input : String) -> Maybe (Command schema) parse schema input = case span (/= ' ') input of (cmd, args) => parseCommand schema cmd (trim args) display : SchemaType schema -> String display {schema = SString} item = show item display {schema = SInt} item = show item display {schema = SChar} item = show item display {schema = (y .+. z)} (iteml, itemr) = display iteml ++ ", " ++ display itemr getEntry : (pos : Integer) -> (store : DataStore) -> Maybe (String, DataStore) getEntry pos store = let store_items = items store in case integerToFin pos (size store) of Nothing => Just ("Out of range\n", store) Just id => Just (display (index id (items store)) ++ "\n", store) showAll : Nat -> Vect size (SchemaType schema) -> String showAll idx [] = "" showAll idx (x :: xs) = show idx ++ ": " ++ display x ++ "\n" ++ showAll (idx + 1) xs processInput : DataStore -> String -> Maybe (String, DataStore) processInput store input = case parse (schema store) input of Nothing => Just ("Invalid command\n", store) Just (Add item) => Just ("ID " ++ show (size store) ++ "\n", addToStore store item) Just (SetSchema schema') => case setSchema store schema' of Nothing => Just ("Can't update schema when entries in store\n", store) Just store' => Just ("OK\n", store') Just (Get (Just pos)) => getEntry pos store Just (Get Nothing) => Just (showAll 0 (items store) ++ "\n", store) Just Quit => Nothing main : IO () main = replWith (MkData (SString .+. SString .+. SInt) _ []) "Command: " processInput ================================================ FILE: Chapter6/Exercises/ex_6_3_3.idr ================================================ module Main import Data.Vect infixr 5 .+. data Schema = SString | SInt | SChar | (.+.) Schema Schema SchemaType : Schema -> Type SchemaType SString = String SchemaType SInt = Int SchemaType SChar = Char SchemaType (x .+. y) = (SchemaType x, SchemaType y) record DataStore where constructor MkData schema : Schema size : Nat items : Vect size (SchemaType schema) addToStore : (store : DataStore) -> SchemaType (schema store) -> DataStore addToStore (MkData schema size store) newitem = MkData schema _ (addToData store) where addToData : Vect oldsize (SchemaType schema) -> Vect (S oldsize) (SchemaType schema) addToData [] = [newitem] addToData (x :: xs) = x :: addToData xs setSchema : (store : DataStore) -> Schema -> Maybe DataStore setSchema store schema = case size store of Z => Just (MkData schema _ []) S k => Nothing data Command : Schema -> Type where SetSchema : Schema -> Command schema Add : SchemaType schema -> Command schema Get : Maybe Integer -> Command schema Quit : Command schema parsePrefix : (schema : Schema) -> String -> Maybe (SchemaType schema, String) parsePrefix SString input = getQuoted (unpack input) where getQuoted : List Char -> Maybe (String, String) getQuoted ('"' :: xs) = case span (/= '"') xs of (quoted, '"' :: rest) => Just (pack quoted, ltrim (pack rest)) _ => Nothing getQuoted _ = Nothing parsePrefix SInt input = case span isDigit input of ("", rest) => Nothing (num, rest) => Just (cast num, ltrim rest) parsePrefix SChar input = case unpack input of (c :: cs) => Just (c, ltrim (pack cs)) [] => Nothing parsePrefix (schemal .+. schemar) input = do (l_val, input') <- parsePrefix schemal input (r_val, input'') <- parsePrefix schemar input' Just ((l_val, r_val), input'') parseBySchema : (schema : Schema) -> String -> Maybe (SchemaType schema) parseBySchema schema x = case parsePrefix schema x of Nothing => Nothing Just (res, "") => Just res Just _ => Nothing parseSchema : List String -> Maybe Schema parseSchema ("String" :: xs) = case xs of [] => Just SString _ => do xs_sch <- parseSchema xs Just (SString .+. xs_sch) parseSchema ("Int" :: xs) = case xs of [] => Just SInt _ => do xs_sch <- parseSchema xs Just (SInt .+. xs_sch) parseSchema ("Char" :: xs) = case xs of [] => Just SInt _ => do xs_sch <- parseSchema xs Just (SChar .+. xs_sch) parseSchema _ = Nothing parseCommand : (schema : Schema) -> String -> String -> Maybe (Command schema) parseCommand schema "add" rest = do restok <- parseBySchema schema rest Just (Add restok) parseCommand schema "get" "" = Just (Get Nothing) parseCommand schema "get" val = case all isDigit (unpack val) of False => Nothing True => Just (Get (Just (cast val))) parseCommand schema "quit" "" = Just Quit parseCommand schema "schema" rest = case parseSchema (words rest) of Nothing => Nothing Just schemaok => Just (SetSchema schemaok) parseCommand _ _ _ = Nothing parse : (schema : Schema) -> (input : String) -> Maybe (Command schema) parse schema input = case span (/= ' ') input of (cmd, args) => parseCommand schema cmd (trim args) display : SchemaType schema -> String display {schema = SString} item = show item display {schema = SInt} item = show item display {schema = SChar} item = show item display {schema = (y .+. z)} (iteml, itemr) = display iteml ++ ", " ++ display itemr getEntry : (pos : Integer) -> (store : DataStore) -> Maybe (String, DataStore) getEntry pos store = let store_items = items store in case integerToFin pos (size store) of Nothing => Just ("Out of range\n", store) Just id => Just (display (index id (items store)) ++ "\n", store) showAll : Nat -> Vect size (SchemaType schema) -> String showAll idx [] = "" showAll idx (x :: xs) = show idx ++ ": " ++ display x ++ "\n" ++ showAll (idx + 1) xs processInput : DataStore -> String -> Maybe (String, DataStore) processInput store input = case parse (schema store) input of Nothing => Just ("Invalid command\n", store) Just (Add item) => Just ("ID " ++ show (size store) ++ "\n", addToStore store item) Just (SetSchema schema') => case setSchema store schema' of Nothing => Just ("Can't update schema when entries in store\n", store) Just store' => Just ("OK\n", store') Just (Get (Just pos)) => getEntry pos store Just (Get Nothing) => Just (showAll 0 (items store) ++ "\n", store) Just Quit => Nothing main : IO () main = replWith (MkData (SString .+. SString .+. SInt) _ []) "Command: " processInput ================================================ FILE: Chapter6/Maybe.idr ================================================ maybeAdd : Maybe Int -> Maybe Int -> Maybe Int maybeAdd x y = case x of Nothing => Nothing Just x_val => case y of Nothing => Nothing Just y_val => Just (x_val + y_val) maybeAdd' : Maybe Int -> Maybe Int -> Maybe Int maybeAdd' x y = x >>= \x_val => y >>= \y_val => Just (x_val + y_val) maybeAdd'' : Maybe Int -> Maybe Int -> Maybe Int maybeAdd'' x y = do x_val <- x y_val <- y Just (x_val + y_val) ================================================ FILE: Chapter6/Printf.idr ================================================ data Format = Number Format | Str Format | Lit String Format | End PrintfType : Format -> Type PrintfType (Number fmt) = (i : Int) -> PrintfType fmt PrintfType (Str fmt) = (str : String) -> PrintfType fmt PrintfType (Lit str fmt) = PrintfType fmt PrintfType End = String printfFmt : (fmt : Format) -> (acc : String) -> PrintfType fmt printfFmt (Number fmt) acc = \i => printfFmt fmt (acc ++ show i) printfFmt (Str fmt) acc = \str => printfFmt fmt (acc ++ str) printfFmt (Lit lit fmt) acc = printfFmt fmt (acc ++ lit) printfFmt End acc = acc toFormat : (xs : List Char) -> Format toFormat [] = End toFormat ('%' :: 'd' :: chars) = Number (toFormat chars) toFormat ('%' :: 's' :: chars) = Str (toFormat chars) toFormat ('%' :: chars) = Lit "%" (toFormat chars) toFormat (c :: chars) = case toFormat chars of Lit lit chars' => Lit (strCons c lit) chars' fmt => Lit (strCons c "") fmt printf : (fmt : String) -> PrintfType (toFormat (unpack fmt)) printf fmt = printfFmt _ "" ================================================ FILE: Chapter6/TypeFuns.idr ================================================ import Data.Vect StringOrInt : Bool -> Type StringOrInt False = String StringOrInt True = Int getStringOrInt : (isInt : Bool) -> StringOrInt isInt getStringOrInt False = "Ninety four" getStringOrInt True = 94 valToString : (isInt : Bool) -> StringOrInt isInt -> String valToString False y = trim y valToString True y = cast y valToString' : (isInt : Bool) -> (case isInt of False => String True => Int) -> String valToString' False y = trim y valToString' True y = cast y ================================================ FILE: Chapter6/TypeSynonyms.idr ================================================ import Data.Vect tri : Vect 3 (Double, Double) tri = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)] Position : Type Position = (Double, Double) tri' : Vect 3 Position tri' = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)] Polygon : Nat -> Type Polygon n = Vect n Position tri'' : Polygon 3 tri'' = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)] ================================================ FILE: Chapter7/Album.idr ================================================ record Album where constructor MkAlbum artist : String title : String year : Integer help : Album help = MkAlbum "The Beatles" "Help" 1965 rubbersoul : Album rubbersoul = MkAlbum "The Beatles" "Rubber Soul" 1965 clouds : Album clouds = MkAlbum "Joni Mitchell" "Clouds" 1969 hunkydory : Album hunkydory = MkAlbum "David Bowie" "Hunky Dory" 1971 heroes : Album heroes = MkAlbum "David Bowie" "Heroes" 1977 collection : List Album collection = [help, rubbersoul, clouds, hunkydory, heroes] Eq Album where (==) (MkAlbum artist title year) (MkAlbum artist' title' year') = artist == artist' && title == title' && year == year' Ord Album where compare (MkAlbum artist title year) (MkAlbum artist' title' year') = case compare artist artist' of EQ => case compare year year' of EQ => compare title title' diff_year => diff_year diff_artist => diff_artist Show Album where show (MkAlbum artist title year) = title ++ " by " ++ artist ++ " (released " ++ show year ++ ")" ================================================ FILE: Chapter7/Eq.idr ================================================ occurrences : Eq ty => (item : ty) -> (values : List ty) -> Nat occurrences item [] = 0 occurrences item (value :: values) = case x == item of False => occurrences item values True => 1 + occurrences item values data Matter = Solid | Liquid | Gas Eq Matter where (==) Solid Solid = True (==) Liquid Liquid = True (==) Gas Gas = True (==) _ _ = False ================================================ FILE: Chapter7/Exercises/ex_7_1.idr ================================================ data Shape = Triangle Double Double | Rectangle Double Double | Circle Double area : Shape -> Double area (Triangle base height) = 0.5 * base * height area (Rectangle length height) = length * height area (Circle radius) = pi * radius * radius {- 1 -} Eq Shape where (==) (Triangle base height) (Triangle base' height') = base == base' && height == height' (==) (Rectangle length height) (Rectangle length' height') = length == length' && height == height' (==) (Circle radius) (Circle radius') = radius == radius' (==) _ _ = False {- 2 -} Ord Shape where compare x y = compare (area x) (area y) testShapes : List Shape testShapes = [Circle 3, Triangle 3 9, Rectangle 2 6, Circle 4, Rectangle 2 7] ================================================ FILE: Chapter7/Exercises/ex_7_2.idr ================================================ data Expr num = Val num | Add (Expr num) (Expr num) | Sub (Expr num) (Expr num) | Mul (Expr num) (Expr num) | Div (Expr num) (Expr num) | Abs (Expr num) eval : (Neg num, Integral num) => Expr num -> num eval (Val x) = x eval (Add x y) = eval x + eval y eval (Sub x y) = eval x - eval y eval (Mul x y) = eval x * eval y eval (Div x y) = eval x `div` eval y eval (Abs x) = abs (eval x) Num ty => Num (Expr ty) where (+) = Add (*) = Mul fromInteger = Val . fromInteger Neg ty => Neg (Expr ty) where negate x = 0 - x (-) = Sub abs = Abs {- 1 -} showOp : Show a => String -> a -> a -> String showOp op x y = "(" ++ show x ++ op ++ show y ++ ")" Show ty => Show (Expr ty) where show (Val x) = show x show (Add x y) = showOp " + " x y show (Sub x y) = showOp " - " x y show (Mul x y) = showOp " * " x y show (Div x y) = showOp " / " x y show (Abs x) = "abs " ++ show x {- 2 -} (Neg a, Integral a, Eq a) => Eq (Expr a) where (==) x y = eval x == eval y {- 3 -} (Neg num, Integral num) => Cast (Expr num) num where cast orig = eval orig ================================================ FILE: Chapter7/Exercises/ex_7_3_1.idr ================================================ data Expr num = Val num | Add (Expr num) (Expr num) | Sub (Expr num) (Expr num) | Mul (Expr num) (Expr num) | Div (Expr num) (Expr num) | Abs (Expr num) eval : (Neg num, Integral num) => Expr num -> num eval (Val x) = x eval (Add x y) = eval x + eval y eval (Sub x y) = eval x - eval y eval (Mul x y) = eval x * eval y eval (Div x y) = eval x `div` eval y eval (Abs x) = abs (eval x) Num ty => Num (Expr ty) where (+) = Add (*) = Mul fromInteger = Val . fromInteger Neg ty => Neg (Expr ty) where negate x = 0 - x (-) = Sub abs = Abs Functor Expr where map f (Val x) = Val (f x) map f (Add x y) = Add (map f x) (map f y) map f (Sub x y) = Sub (map f x) (map f y) map f (Mul x y) = Mul (map f x) (map f y) map f (Div x y) = Div (map f x) (map f y) map f (Abs x) = Abs (map f x) ================================================ FILE: Chapter7/Exercises/ex_7_3_2.idr ================================================ data Vect : Nat -> Type -> Type where Nil : Vect Z a (::) : a -> Vect k a -> Vect (S k) a %name Vect xs, ys Eq a => Eq (Vect n a) where (==) [] [] = True (==) (x :: xs) (y :: ys) = x == y && xs == ys Foldable (Vect n) where foldr f acc [] = acc foldr f acc (x :: xs) = f x (foldr f acc xs) ================================================ FILE: Chapter7/Expr.idr ================================================ data Expr num = Val num | Add (Expr num) (Expr num) | Sub (Expr num) (Expr num) | Mul (Expr num) (Expr num) | Div (Expr num) (Expr num) | Abs (Expr num) eval : (Neg num, Integral num) => Expr num -> num eval (Val x) = x eval (Add x y) = eval x + eval y eval (Sub x y) = eval x - eval y eval (Mul x y) = eval x * eval y eval (Div x y) = eval x `div` eval y eval (Abs x) = abs (eval x) Num ty => Num (Expr ty) where (+) = Add (*) = Mul fromInteger = Val . fromInteger Neg ty => Neg (Expr ty) where negate x = 0 - x (-) = Sub abs = Abs ================================================ FILE: Chapter7/Fold.idr ================================================ totalLen : List String -> Nat totalLen xs = foldr (\str, len => length str + len) 0 xs ================================================ FILE: Chapter7/Tree.idr ================================================ data Tree elem = Empty | Node (Tree elem) elem (Tree elem) Eq elem => Eq (Tree elem) where (==) Empty Empty = True (==) (Node left e right) (Node left' e' right') = left == left' && e == e' && right == right' (==) _ _ = False Functor Tree where map f Empty = Empty map f (Node left e right) = Node (map f left) (f e) (map f right) Foldable Tree where foldr f acc Empty = acc foldr f acc (Node left e right) = let leftfold = foldr f acc left rightfold = foldr f leftfold right in f e rightfold ================================================ FILE: Chapter8/AppendVec.idr ================================================ import Data.Vect append_nil : Vect m elem -> Vect (plus m 0) elem append_nil {m} xs = rewrite plusZeroRightNeutral m in xs append_xs : Vect (S (m + k)) elem -> Vect (plus m (S k)) elem append_xs {m} {k} xs = rewrite sym (plusSuccRightSucc m k) in xs append : Vect n elem -> Vect m elem -> Vect (m + n) elem append [] ys = append_nil ys append (x :: xs) ys = append_xs (x :: append xs ys) ================================================ FILE: Chapter8/CheckEqDec.idr ================================================ zeroNotSuc : (0 = S k) -> Void zeroNotSuc Refl impossible sucNotZero : (S k = 0) -> Void sucNotZero Refl impossible noRec : (contra : (k = j) -> Void) -> (S k = S j) -> Void noRec contra Refl = contra Refl checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Dec (num1 = num2) checkEqNat Z Z = Yes Refl checkEqNat Z (S k) = No zeroNotSuc checkEqNat (S k) Z = No sucNotZero checkEqNat (S k) (S j) = case checkEqNat k j of Yes prf => Yes (cong prf) No contra => No (noRec contra) ================================================ FILE: Chapter8/CheckEqMaybe.idr ================================================ checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (num1 = num2) checkEqNat Z Z = Just Refl checkEqNat Z (S k) = Nothing checkEqNat (S k) Z = Nothing checkEqNat (S k) (S j) = case checkEqNat k j of Nothing => Nothing Just prf => Just (cong prf) ================================================ FILE: Chapter8/EqNat.idr ================================================ data EqNat : Nat -> Nat -> Type where Same : (x : Nat) -> EqNat x x sameS : (k : Nat) -> (j : Nat) -> (eq : EqNat k j) -> EqNat (S k) (S j) sameS k k (Same k) = Same (S k) checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (EqNat num1 num2) checkEqNat Z Z = Just (Same Z) checkEqNat Z (S k) = Nothing checkEqNat (S k) Z = Nothing checkEqNat (S k) (S j) = case checkEqNat k j of Nothing => Nothing Just eq => Just (sameS _ _ eq) ================================================ FILE: Chapter8/ExactLength.idr ================================================ data Vect : Nat -> Type -> Type where Nil : Vect Z a (::) : a -> Vect k a -> Vect (S k) a %name Vect xs, ys, zs data EqNat : Nat -> Nat -> Type where Same : (x : Nat) -> EqNat x x sameS : (k : Nat) -> (j : Nat) -> (eq : EqNat k j) -> EqNat (S k) (S j) sameS k k (Same k) = Same (S k) checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (EqNat num1 num2) checkEqNat Z Z = Just (Same Z) checkEqNat Z (S k) = Nothing checkEqNat (S k) Z = Nothing checkEqNat (S k) (S j) = case checkEqNat k j of Nothing => Nothing Just eq => Just (sameS _ _ eq) exactLength : (len : Nat) -> (input : Vect m a) -> Maybe (Vect len a) exactLength {m} len input = case checkEqNat m len of Nothing => Nothing Just (Same len) => Just input ================================================ FILE: Chapter8/ExactLengthDec.idr ================================================ data Vect : Nat -> Type -> Type where Nil : Vect Z a (::) : a -> Vect k a -> Vect (S k) a %name Vect xs, ys, zs exactLength : (len : Nat) -> (input : Vect m a) -> Maybe (Vect len a) exactLength {m} len input = case decEq m len of Yes Refl => Just input No contra => Nothing ================================================ FILE: Chapter8/Exercises/ex_8_1.idr ================================================ {- 1 -} same_cons : {xs : List a} -> {ys : List a} -> xs = ys -> x :: xs = x :: ys same_cons Refl = Refl {- 2 -} same_lists : {xs : List a} -> {ys : List a} -> x = y -> xs = ys -> x :: xs = y :: ys same_lists Refl Refl = Refl {- 3 -} data ThreeEq : a -> b -> c -> Type where AllSame : ThreeEq x x x {- 4 -} allSameS : (x, y, z : Nat) -> ThreeEq x y z -> ThreeEq (S x) (S y) (S z) allSameS x x x AllSame = AllSame -- If you add a successor to three equal Nats, the results are all equal ================================================ FILE: Chapter8/Exercises/ex_8_2.idr ================================================ import Data.Vect {- 1 -} myPlusCommutes : (n : Nat) -> (m : Nat) -> n + m = m + n myPlusCommutes Z m = rewrite plusZeroRightNeutral m in Refl myPlusCommutes (S k) m = rewrite myPlusCommutes k m in rewrite plusSuccRightSucc m k in Refl {- 2 -} reverseProof_nil : Vect n a -> Vect (plus n 0) a reverseProof_nil {n} xs = rewrite plusZeroRightNeutral n in xs reverseProof_xs : Vect (S n + k) a -> Vect (plus n (S k)) a reverseProof_xs {n} {k} xs = rewrite sym (plusSuccRightSucc n k) in xs myReverse : Vect n a -> Vect n a myReverse xs = reverse' [] xs where reverse' : Vect n a -> Vect m a -> Vect (n+m) a reverse' acc [] = reverseProof_nil acc reverse' acc (x :: xs) = reverseProof_xs (reverse' (x::acc) xs) ================================================ FILE: Chapter8/Exercises/ex_8_3.idr ================================================ data Vect : Nat -> Type -> Type where Nil : Vect Z a (::) : a -> Vect k a -> Vect (S k) a %name Vect xs, ys, zs {- 1 -} headUnequal : DecEq a => {xs : Vect n a} -> {ys : Vect n a} -> (contra : (x = y) -> Void) -> (x :: xs) = (y :: ys) -> Void headUnequal contra Refl = contra Refl tailUnequal : DecEq a => {xs : Vect n a} -> {ys : Vect n a} -> (contra : (xs = ys) -> Void) -> (x :: xs) = (y :: ys) -> Void tailUnequal contra Refl = contra Refl {- 2 -} DecEq a => DecEq (Vect n a) where decEq [] [] = Yes Refl decEq (x :: xs) (y :: ys) = case decEq x y of No contra => No (headUnequal contra) Yes Refl => case decEq xs ys of Yes Refl => Yes Refl No contra => No (tailUnequal contra) ================================================ FILE: Chapter8/ReverseVec.idr ================================================ import Data.Vect myReverse1 : Vect n a -> Vect n a myReverse1 [] = [] myReverse1 {n = S k} (x :: xs) = let result = myReverse1 xs ++ [x] in rewrite plusCommutative 1 k in result myReverse : Vect n a -> Vect n a myReverse [] = [] myReverse (x :: xs) = reverseProof (myReverse xs ++ [x]) where reverseProof : Vect (k + 1) a -> Vect (S k) a reverseProof {k} result = rewrite plusCommutative 1 k in result ================================================ FILE: Chapter8/TCVects.idr ================================================ import Data.Vect test1 : Vect 4 Int test1 = [1, 2, 3, 4] test2: Vect (2 + 2) Int test2 = ?test2_rhs ================================================ FILE: Chapter8/Void.idr ================================================ twoPlusTwoNotFive : 2 + 2 = 5 -> Void twoPlusTwoNotFive Refl impossible valueNotSuc : (x : Nat) -> x = S x -> Void valueNotSuc _ Refl impossible loop : Void loop = loop nohead : Void nohead = getHead [] where getHead : List Void -> Void getHead (x :: xs) = x ================================================ FILE: Chapter9/Elem.idr ================================================ import Data.Vect oneInVector : Elem 1 [1,2,3] oneInVector = Here maryInVector : Elem "Mary" ["Peter", "Paul", "Mary"] maryInVector = There (There Here) fourNotInVector : Elem 4 [1,2,3] -> Void fourNotInVector (There (There (There Here))) impossible fourNotInVector (There (There (There (There _)))) impossible peteNotInVector : Elem "Pete" ["John", "Paul", "George", "Ringo"] -> Void peteNotInVector (There (There (There (There Here)))) impossible peteNotInVector (There (There (There (There (There _))))) impossible ================================================ FILE: Chapter9/ElemBool.idr ================================================ data Vect : Nat -> Type -> Type where Nil : Vect Z a (::) : a -> Vect k a -> Vect (S k) a %name Vect xs, ys, zs elem : Eq a => (value : a) -> (xs : Vect n a) -> Bool elem value [] = False elem value (x :: xs) = case value == x of False => elem value xs True => True ================================================ FILE: Chapter9/ElemType.idr ================================================ data Vect : Nat -> Type -> Type where Nil : Vect Z a (::) : a -> Vect k a -> Vect (S k) a %name Vect xs, ys, zs data Elem : a -> Vect k a -> Type where Here : Elem x (x :: xs) There : (later : Elem x xs) -> Elem x (y :: xs) not_in_nil : Elem value [] -> Void not_in_nil Here impossible not_in_nil (There _) impossible not_in_tail : (notThere : Elem value xs -> Void) -> (notHere : (value = x) -> Void) -> Elem value (x :: xs) -> Void not_in_tail notThere notHere Here = notHere Refl not_in_tail notThere notHere (There later) = notThere later isElem : DecEq a => (value : a) -> (xs : Vect n a) -> Dec (Elem value xs) isElem value [] = No not_in_nil isElem value (x :: xs) = case decEq value x of Yes Refl => Yes Here No notHere => case isElem value xs of Yes prf => Yes (There prf) No notThere => No (not_in_tail notThere notHere) ================================================ FILE: Chapter9/Exercises/ex_9_1.idr ================================================ {- 1 -} data Elem : a -> List a -> Type where Here : Elem x (x :: xs) There : Elem x xs -> Elem x (y :: xs) {- 2 -} data Last : List a -> a -> Type where LastOne : Last [value] value LastCons : (prf : Last xs value) -> Last (x :: xs) value lastNotNil : (value : a) -> Last [] x -> Void lastNotNil _ LastOne impossible lastNotNil _ (LastCons _) impossible lastNotCons : (contra : Last (x :: xs) value -> Void) -> Last (y :: (x :: xs)) value -> Void lastNotCons contra (LastCons prf) = contra prf lastNotSingleton : (contra : (y = value) -> Void) -> Last [y] value -> Void lastNotSingleton contra LastOne = contra Refl lastNotSingleton _ (LastCons LastOne) impossible lastNotSingleton _ (LastCons (LastCons _)) impossible isLast : DecEq a => (xs : List a) -> (value : a) -> Dec (Last xs value) isLast [] value = No (lastNotNil value) isLast (y :: []) value = case decEq y value of (Yes Refl) => Yes LastOne (No contra) => No (lastNotSingleton contra) isLast (y :: (x :: xs)) value = case isLast (x :: xs) value of (Yes prf) => Yes (LastCons prf) (No contra) => No (lastNotCons contra) ================================================ FILE: Chapter9/Hangman.idr ================================================ import Data.Vect data WordState : (guesses : Nat) -> (letters : Nat) -> Type where MkWordState : (word : String) -> (missing : Vect letters Char) -> WordState guesses_remaining letters data Finished : Type where Lost : (game : WordState 0 (S letters)) -> Finished Won : (game : WordState (S guesses) 0) -> Finished total removeElem : (value : a) -> (xs : Vect (S n) a) -> {auto prf : Elem value xs} -> Vect n a removeElem value (value :: ys) {prf = Here} = ys removeElem {n = Z} value (y :: []) {prf = There later} = absurd later removeElem {n = (S k)} value (y :: ys) {prf = There later} = y :: removeElem value ys processGuess : (letter : Char) -> WordState (S guesses) (S letters) -> Either (WordState guesses (S letters)) (WordState (S guesses) letters) processGuess letter (MkWordState word missing) = case isElem letter missing of Yes prf => Right (MkWordState word (removeElem letter missing)) No contra => Left (MkWordState word missing) data ValidInput : List Char -> Type where Letter : (c : Char) -> ValidInput [c] isValidNil : ValidInput [] -> Void isValidNil (Letter _) impossible isValidTwo : ValidInput (x :: (y :: xs)) -> Void isValidTwo (Letter _) impossible isValidInput : (cs : List Char) -> Dec (ValidInput cs) isValidInput [] = No isValidNil isValidInput (x :: []) = Yes (Letter x) isValidInput (x :: (y :: xs)) = No isValidTwo isValidString : (s : String) -> Dec (ValidInput (unpack s)) isValidString s = isValidInput (unpack s) readGuess : IO (x ** ValidInput x) readGuess = do putStr "Guess: " x <- getLine case isValidString (toUpper x) of Yes prf => pure (_ ** prf) No contra => do putStrLn "Invalid guess" readGuess game : WordState (S guesses) (S letters) -> IO Finished game {guesses} {letters} st = do (_ ** Letter letter) <- readGuess case processGuess letter st of Left l => do putStrLn ("Wrong! " ++ show guesses ++ " guesses remaining") case guesses of Z => pure (Lost l) S k => game l Right r => do putStrLn "Right!" case letters of Z => pure (Won r) S k => game r main : IO () main = do result <- game {guesses=2} (MkWordState "Test" ['T', 'E', 'S']) case result of Lost (MkWordState word missing) => putStrLn ("You lose. The word was " ++ word) Won game => putStrLn "You win!" ================================================ FILE: Chapter9/RemoveElem.idr ================================================ import Data.Vect removeElem_v1 : DecEq a => (value : a) -> (xs : Vect (S n) a) -> Vect n a removeElem_v1 value (x :: xs) = case decEq value x of Yes prf => xs No contra => ?removeElem_v1_rhs -- x :: removeElem_v1 value xs Uninhabited (2 + 2 = 5) where uninhabited Refl impossible {-} removeElem : (value : a) -> (xs : Vect (S n) a) -> Elem value xs -> Vect n a removeElem value (value :: ys) Here = ys removeElem {n = Z} value (y :: []) (There later) = absurd later removeElem {n = (S k)} value (y :: ys) (There later) = y :: removeElem value ys later removeElem_auto : (value : a) -> (xs : Vect (S n) a) -> {auto prf : Elem value xs} -> Vect n a removeElem_auto value xs {prf} = removeElem value xs prf -} removeElem : (value : a) -> (xs : Vect (S n) a) -> {auto prf : Elem value xs} -> Vect n a removeElem value (value :: ys) {prf = Here} = ys removeElem {n = Z} value (y :: []) {prf = There later} = absurd later removeElem {n = (S k)} value (y :: ys) {prf = There later} = y :: removeElem value ys my_elem : Eq a => (value : a) -> (xs : Vect n a) -> Bool my_elem value [] = False my_elem value (x :: xs) = case value == x of False => my_elem value xs True => True not_in_nil : Elem value [] -> Void not_in_nil Here impossible not_in_nil (There _) impossible not_in_tail : (contra1 : Elem value xs -> Void) -> (contra : (value = x) -> Void) -> Elem value (x :: xs) -> Void not_in_tail contra1 contra Here = contra Refl not_in_tail contra1 contra (There later) = contra1 later my_decElem : DecEq a => (value : a) -> (xs : Vect n a) -> Dec (Elem value xs) my_decElem value [] = No not_in_nil my_decElem value (x :: xs) = case decEq value x of (Yes Refl) => Yes Here (No contra) => case my_decElem value xs of (Yes prf) => Yes (There prf) (No contra1) => No (not_in_tail contra1 contra) ================================================ FILE: LICENSE ================================================ The MIT License (MIT) Copyright (c) 2017 Manning Publications Co. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ================================================ FILE: README.md ================================================ # Type Driven Development with Idris Sample code and exercise solutions from "Type Driven Development with Idris", available from https://www.manning.com/books/type-driven-development-with-idris