Monadic LOGO Large Step Interpreter

open System

//F# State Monad

type State<'state, 'a> = State of ('state ->'a * 'state)

type StateMonad() = 
        member b.Bind(m, f) = State (fun s -> let r = match m with
                                                      | State f -> f s
                                              match r with
                                              | (v,s) -> match f v with
                                                         | State f -> f s)    
        member b.Return(x) = State (fun s -> x, s)

let state = StateMonad()

let GetState = State (fun s -> s, s)
let SetState s = State (fun s' -> (), s)  

let Execute m s = match m with
                  | State f -> let (x,s') = f s
                               s'
                               
let rec ForEach f xs =  
                state {
                        match xs with
                        | x :: xs' -> do! f x                                      
                                      return! ForEach f xs'
                        | [] -> return ()
                      }

let sin = Math.Sin
let cos = Math.Cos
let atan = Math.Atan

let float_of_int x = (float x)
let int_of_float x = (int x)

type logo = | Home
            | Forward of int
            | Turn of int
            | For of int * logo list

let pi = 4.0 * atan 1.0
let dsin t = sin(pi * (float_of_int t) / 180.0) 
and dcos t = cos(pi * (float_of_int t) / 180.0)

let AddToState x = state { let! xs = GetState  
                           do! SetState (x::xs) }

let GoHome = state { do! AddToState (0,0,0) }

let GoForward n = state { let! (x,y,d)::xs = GetState
                          do! AddToState (x + (int_of_float ((float n) * dsin d)), y + (int_of_float ((float n) * dcos d)), d) }                            
let GoTurn n = state { let! (x,y,d)::xs = GetState 
                       do! AddToState (x,y,d+n) }


let rec interpret e = state { 
                             do! match e with
                                 | Home -> GoHome
                                 | Forward n -> GoForward n
                                 | Turn(n) -> GoTurn n
                                 | For(i, es) -> if i > 0 then
                                                    state {
                                                            do! interpret_prog es
                                                            do! interpret (For(i - 1, es))
                                                          }
                                                 else
                                                    state { return () } }
and interpret_prog xs = ForEach interpret xs  

let sample = [Home; For(20, [Turn 18; For(36, [Forward 10; Turn 10])])]

let Run = Execute(interpret_prog sample) [(0,0,0)] |> List.to_array

LOGO Translator

open System;
let sin = Math.Sin
let cos = Math.Cos 
let atan = Math.Atan
let float_of_int x = (float x)
let int_of_float x = (int x)
  

type logo = | Home
            | Forward of int
            | Turn of int
            | For of int * logo list
  

let pi = 4.0 * atan 1.0
let dsin t = sin(pi * (float_of_int t) / 180.0)
and dcos t = cos(pi * (float_of_int t) / 180.0)
  

let forward (x,y,d) steps =  (x + (int_of_float ((float steps) * dsin d)),
                              y + (int_of_float ((float steps) * dcos d)), d)
  

let compose f g = fun x -> f(g(x))
  

let rec translate h x = match x with
                        | Home -> fun pos -> pos
                        | Forward(n) -> fun pos ->
                                                    let pos' = forward pos n
                                                    h pos'
                        | Turn(n) -> fun (x,y,d) -> (x,y,d + n)
                        | For(i, xs) -> let f = translate_prog h xs in
                                        if i > 1 then
                                           compose f (translate h (For(i - 1, xs)))
                                        else
                                           f
and translate_prog h xs = List.fold_left (fun f x -> compose (translate h x) f) (fun pos -> pos) xs             
let current = (0, 0, 0)
let sample = [Home; For(20, [Turn 18; For(36, [Forward 10; Turn 10])])]
  

let f = translate_prog (fun x -> (printf "%A" x) ; x) sample
  

let result = f current

LOGO Large Step Interpreter

open System;
  

let sin = Math.Sin
let cos = Math.Cos
let atan = Math.Atan
  

let float_of_int x = (float x)
let int_of_float x = (int x)
  

type logo = | Home
            | Forward of int
            | Turn of int
            | For of int * logo list
  

let pi = 4.0 * atan 1.0
let dsin t = sin(pi * (float_of_int t) / 180.0)
and dcos t = cos(pi * (float_of_int t) / 180.0)
  

let rec interpret f (x,y,d) e =
   let interpret' (x,y,d) e = match e with
                              | Home -> (0,0,0)
                              | Forward(n) -> (x + (int_of_float ((float n) * dsin d)), y + (int_of_float ((float n) * dcos d)), d)
                              | Turn(n) ->  (x, y, d + n)
                              | For(i, xs) -> if i > 0 then
                                                interpret f (interpret_prog f (x,y,d) xs) (For(i - 1, xs))
                                              else
                                                (x,y,d)
   f (x,y,d)
   interpret' (x,y,d) e
and interpret_prog f pos xs =  match xs with
                               | x::xs' ->  interpret_prog f (interpret f pos x) xs'              
                               | [] -> pos
  

let current = (0, 0, 0)
let sample = [Home; For(20, [Turn 18; For(36, [Forward 10; Turn 10])])]
  

let result = interpret_prog (printf "%A") current sample

Bowling Game Kata Implementation

//Bowling Game Kata Implementation

open StateMonad

let AllPins = 10
let ZeroPins = 0

let IsStrike(roll, _) = roll = AllPins
let IsSpare(roll, nextRoll) = (roll + nextRoll) = AllPins
let SpareBonus rolls = match rolls with
                       | (rollA, rollB)::rolls' -> rollA
                       | [] -> 0
let StrikeBonus rolls =  match rolls with
                         | (rollA,rollB)::rolls' -> rollA + if rollA = AllPins then rollA else rollB
                         | [] -> 0

let frames rolls =
       let rec frames' rolls =
           match rolls with
           | rollA::rollB::[] -> [(rollA,rollB)]
           | rollA::rollB::rolls' ->  if (IsStrike(rollA, rollB)) then
                                           (rollA, ZeroPins)    :: frames' (rollB::rolls')
                                      else
                                           (rollA, rollB)       :: frames' rolls'
           | rollA::[] -> [(rollA, ZeroPins)]
       frames' rolls
      
                   
let NextScoreNoBonus prevScore rollA rollB = prevScore + rollA + rollB
      
let rec totals xs score =
 match xs with
 | (x,y)::[] when x < AllPins -> (NextScoreNoBonus score x y)
 | (_,_)::[] -> score
 | (x,y)::xs ->
   if (IsStrike(x,y)) then
      totals xs (score + x + StrikeBonus xs)
   else
       if (IsSpare(x,y)) then
           totals xs ((NextScoreNoBonus score x y) + SpareBonus xs)
       else
           totals xs (NextScoreNoBonus score x y)
 | [] -> score


let Score m = Execute (state { do! m
                               let! score = GetState
                               return score }) []
let Total xs = (totals (frames xs) 0)

let Roll(pins) = state { let! s = GetState
                        do! SetState(s @ [pins]) }

let RollList xs = state { let! xs' = MMap (fun s -> state { do! Roll s }) xs
                         return () }

let RollMany t s = state { do! RollList (List.map (fun _ -> s) [1..t]) }
                         
let RollSpare = state { do! Roll 5
                        do! Roll 5 }
                      
let RollStrike = state { do! Roll 10 }

Bowling Game Kata Tests

// Bowling Game Kata Tests

open NUnit.Framework
open Bowling
open StateMonad
                                         
[<TestFixture>]
type BowlingTests =
   new() = {}
      
   [<Test>]
   member x.gutterGame() =
       Assert.AreEqual(0, Score(RollMany 20 0) |> Total)
      
   [<Test>]
   member x.allOnes() =
       Assert.AreEqual(20, Score(RollMany 20 1) |> Total)
      
   [<Test>]
   member x.oneSpare() = 
       Assert.AreEqual(16, Score(state {  do! RollSpare
                                          do! Roll 3
                                          do! RollMany 17 0 }) |> Total)                                    
   [<Test>]
   member x.oneStrike() =
       Assert.AreEqual(24, Score(state { do! RollStrike
                                         do! Roll 3
                                         do! Roll 4
                                         do! RollMany 16 0 }) |> Total)                                     
   [<Test>]
   member x.perfectGame() =
       Assert.AreEqual(300, Score(state { do! RollMany 12 10 }) |> Total)

F# Monadically label n-ary tree

// F# Monadically label n-ary tree
let MMap f xs = 
            let rec MMap' (f, xs', out) = 
                state {
                        match xs' with
                        | h :: t -> let! h' = f(h)
                                    return! MMap'(f, t, List.append out [h'])
                        | [] -> return out
                      }
            MMap' (f, xs, [])

type 'a ntree = | NLeaf of 'a
                | NNode of 'a ntree list


let rec private MNNode (x) =
    match x with
    | NLeaf(c) -> state { let! x = GetState
                          do! SetState (x + 1)
                          return NLeaf(c,x) }
                         
    | NNode(xs) -> state { let! xs' = MMap MNNode xs
                           return NNode(xs')  } 
                    
let MNLabel x = Execute(MNNode(x))    

F# State Monad

//F# State Monad

type State<'state, 'a> = State of ('state ->'a * 'state)

type StateMonad() = 
        member b.Bind(m, f) = State (fun s -> let r = match m with
                                                      | State f -> f s
                                              match r with
                                              | (v,s) -> match f v with
                                                         | State f -> f s)    
        member b.Return(x) = State (fun s -> x, s)

let state = StateMonad()

let GetState = State (fun s -> s, s)
let SetState s = State (fun _ -> (), s)  

let Execute m s = match m with
                  | State f -> let r = f s
                               match r with
                               |(x,_) -> x

F# Monadic tree labeller

open StateMonad

type 'a tree = | Leaf of 'a
               | Node of 'a tree * 'a tree
            
          
// F# Monadic tree labeller 

let rec private mNode x =
    match x with
    | Leaf(c) -> state { let! x = GetState
                         do! SetState (x + 1)
                         return Leaf(c,x) }
                         
    | Node(l,r) -> state { let! l = mNode(l)
                           let! r = mNode(r)
                           return Node(l,r) }
                    
let mLabel x = Execute(mNode(x))


// F# Non-Monadic manual state passing tree labeller

let Label a s = 
     let rec Lab' a s = 
                match a with 
                |Leaf(c) -> (Leaf(c,s), s + 1) 
                
                |Node(l,r) -> let l' = Lab' l s 
                              let r' = Lab' r (snd l')
                              (Node(fst l', fst r'), (snd r')) 
     fst (Lab' a s) 

The List Monad in F#

// The List Monad in F#

type ListMonad() =
   member o.Bind(  (m:'a list), (f: 'a -> 'b list) ) = List.concat( List.map (fun x -> f x) m )
   member o.Return(x) = [x]

let list = ListMonad()

let cartesian = list { let! x = [1..3]
                       let! y = [4..6]
                       return (x,y) }

printf "%A" cartesian

F# Monadic Parser - Calculator Example.

//F# Monadic Parser - Calculator Example :))) 

// Grammar
//expr ::= expr addop term j term
//term ::= term mulop factor j factor
//factor ::= digit j ( expr )
//digit ::= 0 j 1 j : : : j 9
//addop ::= + j -
//mulop ::= * j /

let addOp = parser { let! _ = symb "+" 
                     return (+) } +++ parser { let! _ = symb "-" 
                                               return (-) } 
let mulOp = parser { let! _ = symb "*" 
                     return (*) } +++ parser { let! _ = symb "/" 
                                               return (/) }  
let digit = parser { let! x = token (sat (fun ch -> Char.IsDigit(ch)))
                     return Char.GetNumericValue(x) - Char.GetNumericValue('0') }

let rec expr   = chainl1 term addOp
and     term   = chainl1 factor mulOp
and     factor = digit +++ parser { let! _ = symb "("
                                    let! n = expr
                                    let! _ = symb ")"
                                    return n }
                                    
let parse s = match apply expr s  with
              | [] -> failwith "failed to parse"
              | (ret, _)::xs -> ret 
              
parse "5 * (3 + 4)"              
|> printf "%A"