Turtle 16: Batch processing using command objects with responses

.Turtle-Steps.md

16: Batch processing using command objects with responses

The description is the same as the case 9 with the last disadvantage resolved. Namely

• Only suitable when control flow is not based on the response from a previous command.
  • Case 16 solves this issue, commands have responses.

Below is the case 9 notes:

9: Batch processing using command objects

In this design, the client creates a list of Commands that will be intepreted later. These commands are then run in sequence using the Turtle library functions.

This approach means that there is no state that needs to be persisted between calls by the client.

Advantages

• Simpler to construct and use than workflows or monads.
• Only one function is coupled to a particular implementation. The rest of the client is decoupled.

Disadvantages

• Batch oriented only.
• Only suitable when control flow is not based on the response from a previous command.
  • Case 16 solves this issue, commands have responses.

16-CommandsWithResponses.fsx

(* ======================================
16-CommandsWithResponses.fsx

Part of "Thirteen ways of looking at a turtle"
Related blog post: http://fsharpforfunandprofit.com/posts/13-ways-of-looking-at-a-turtle/
======================================

Way #16: Sequence processing using commands with responses

This design extends #9, the client generates commands that will be interpreted later.
These commands are then run in sequence using the Turtle library functions.
The difference from #9 is that command sequences depend on responses.

This approach means that there is no state that needs to be persisted between calls by the client.
Instead, commands request data for processing and branching the command sequence.

====================================== *)

#load "Common.fsx"
#load "FPTurtleLib2.fsx"

open Common
open FPTurtleLib2

// ======================================
// TurtleCommandHandler
// ======================================

module TurtleCommandHandler =

    /// Function to log a message
    let log message =
        printfn "%s" message

    // logged versions
    let move = Turtle.move log
    let turn = Turtle.turn log
    let penDown = Turtle.penDown log
    let penUp = Turtle.penUp log
    let setColor = Turtle.setColor log

    type TurtleCommand =
        | Move of Distance * Turtle.MoveResponse ref
        | Turn of Angle
        | PenUp
        | PenDown
        | SetColor of PenColor * Turtle.SetColorResponse ref

    // --------------------------------------
    // The Command Handler
    // --------------------------------------

    /// Apply a command to the turtle state and return the new state
    let applyCommand state command =
        match command with
        | Move (distance, r) ->
            let res, state = move distance state
            r := res
            state
        | Turn angle ->
            turn angle state
        | PenUp ->
            penUp state
        | PenDown ->
            penDown state
        | SetColor (color, r) ->
            let res, state = setColor color state
            r := res
            state

    /// Run sequence of commands
    let run aSeqOfCommands =
        aSeqOfCommands
        |> Seq.fold applyCommand Turtle.initialTurtleState

// ======================================
// TurtleCommandClient
// ======================================

module TurtleCommandClient =
    open TurtleCommandHandler

    // create the fixed array of commands
    let drawShape1() =
        let r = ref Turtle.MoveOk
        [|
            Move (60.0, r)
            Move (60.0, r)
            Move (60.0, r)
        |]

    // create commands to move and handle the response
    let moveWithResponse distance = seq {
        let r = ref Turtle.MoveOk
        yield Move (distance, r)

        match !r with
        | Turtle.MoveOk ->
            ()
        | Turtle.HitABarrier ->
            printfn "Oops -- hit a barrier -- turning"
            yield Turn 90.0<Degrees>
    }

    // create commands to set a color and handle the response
    let setColorWithResponse color = seq {
        let r = ref Turtle.ColorOk
        yield SetColor (color, r)

        match !r with
        | Turtle.ColorOk ->
            ()
        | Turtle.OutOfInk ->
            printfn "Oops -- out of ink -- using black"
            yield SetColor (Black, r)
    }

    // compose the sequence of moves with responses
    let drawShape2() = seq {
        yield! moveWithResponse 60.0
        yield! moveWithResponse 60.0
        yield! moveWithResponse 60.0
    }

    // combine shapes with different colors
    let drawShape3() = seq {
        yield! setColorWithResponse Blue
        yield! drawShape2()
        yield! setColorWithResponse Red
        yield! drawShape1()
    }

// ======================================
// TurtleCommandClient Tests
// ======================================

// run program 1
TurtleCommandClient.drawShape1()
|> TurtleCommandHandler.run

// run program 2
TurtleCommandClient.drawShape2()
|> TurtleCommandHandler.run

// run combined program
TurtleCommandClient.drawShape3()
|> TurtleCommandHandler.run

Common.fsx

(*
Common.fsx

Part of "Thirteen ways of looking at a turtle"
Related blog post: http://fsharpforfunandprofit.com/posts/13-ways-of-looking-at-a-turtle/

*)

open System

// ======================================
// Common types and helper functions
// ======================================

/// An alias for a float
type Distance = float

/// Use a unit of measure to make it clear that the angle is in degrees, not radians
type [<Measure>] Degrees

/// An alias for a float of Degrees
type Angle  = float<Degrees>

/// Enumeration of available pen states
type PenState = Up | Down

/// Enumeration of available pen colors
type PenColor = Black | Red | Blue

/// A structure to store the (x,y) coordinates
type Position = {x:float; y:float}


// ======================================
// Common helper functions
// ======================================

// round a float to two places to make it easier to read
let round2 (flt:float) = Math.Round(flt,2)

/// calculate a new position from the current position given an angle and a distance
let calcNewPosition (distance:Distance) (angle:Angle) currentPos = 
    // Convert degrees to radians with 180.0 degrees = 1 pi radian
    let angleInRads = angle * (Math.PI/180.0) * 1.0<1/Degrees> 
    // current pos
    let x0 = currentPos.x
    let y0 = currentPos.y
    // new pos
    let x1 = x0 + (distance * cos angleInRads)
    let y1 = y0 + (distance * sin angleInRads)
    // return a new Position
    {x=round2 x1; y=round2 y1}
        
/// Default initial state
let initialPosition,initialColor,initialPenState = 
    {x=0.0; y=0.0}, Black, Down

/// Emulating a real implementation for drawing a line
let dummyDrawLine log oldPos newPos color =
    // for now just log it
    log (sprintf "...Draw line from (%0.1f,%0.1f) to (%0.1f,%0.1f) using %A" oldPos.x oldPos.y newPos.x newPos.y color)

/// trim a string 
let trimString (str:string) = str.Trim()

// ======================================
// Result type and companion module
// ======================================

type Result<'a,'error> = 
    | Success of 'a
    | Failure of 'error

module Result = 

    let returnR x = 
        Success x

    let bindR f xR = 
        match xR with
        | Success x -> f x
        | Failure err -> Failure err 

    // infix version of bind
    let ( >>= ) xR f = 
        bindR f xR

    let mapR f = 
        bindR (f >> returnR)

    // infix version of map
    let ( <!> ) = mapR 

    let applyR fR xR = 
        fR >>= (fun f ->
        xR >>= (fun x ->
            returnR (f x) ))

    // infix version of apply
    let ( <*> ) = applyR

    // lift a one-parameter function to result world (same as mapR)
    let lift1R f x = f <!> x 

    // lift a two-parameter function to result world
    let lift2R f x y = f <!> x <*> y

    /// Computation Expression
    type ResultBuilder() =
        member this.Bind(m:Result<'a,'error>,f:'a -> Result<'b,'error>) = 
            bindR f m
        member this.Return(x) :Result<'a,'error> = 
            returnR x
        member this.ReturnFrom(m) :Result<'a,'error> = 
            m
        member this.Zero() :Result<unit,'error> = 
            this.Return ()
        member this.Combine(m1, f) = 
            this.Bind(m1, f)
        member this.Delay(f) = 
            f
        member this.Run(m) = 
            m()
        member this.TryWith(m:Result<'a,'error>, h: exn -> Result<'a,'error>) =
            try this.ReturnFrom(m)
            with e -> h e
        member this.TryFinally(m:Result<'a,'error>, compensation) =
            try this.ReturnFrom(m)
            finally compensation()
        member this.Using(res:#IDisposable, body) : Result<'b,'error> =
            this.TryFinally(body res, (fun () -> match res with null -> () | disp -> disp.Dispose()))
        member this.While(cond, m) =
            if not (cond()) then 
                this.Zero()
            else
                this.Bind(m(), fun _ -> this.While(cond, m))
        member this.For(sequence:seq<_>, body) =
            this.Using(sequence.GetEnumerator(),
                (fun enum -> this.While(enum.MoveNext, fun _ -> body enum.Current)))
        
    let result = ResultBuilder()

FPTurtleLib2.fsx

(* ======================================
FPTurtleLib2.fsx

Part of "Thirteen ways of looking at a turtle"
Related blog post: http://fsharpforfunandprofit.com/posts/13-ways-of-looking-at-a-turtle/
======================================

Common code for FP-style immutable turtle functions.

Unlike FPTurtleLib.fsx, the Move and SetColor functions return a response.

====================================== *)

// requires Common.fsx to be loaded by parent file
// Uncomment to use this file standalone
//#load "Common.fsx"

open System
open Common


// ======================================
// Turtle module
// ======================================

module Turtle = 

    type TurtleState = {
        position : Position
        angle : float<Degrees>
        color : PenColor
        penState : PenState
    }
    
    type MoveResponse = 
        | MoveOk 
        | HitABarrier

    type SetColorResponse = 
        | ColorOk
        | OutOfInk

    let initialTurtleState = {
        position = initialPosition
        angle = 0.0<Degrees>
        color = initialColor
        penState = initialPenState
    }                

    // if the position is outside the square (0,0,100,100) 
    // then constrain the position and return HitABarrier
    let checkPosition position =
        let isOutOfBounds p = 
            p > 100.0 || p < 0.0
        let bringInsideBounds p = 
            max (min p 100.0) 0.0

        if isOutOfBounds position.x || isOutOfBounds position.y then
            let newPos = {
                x = bringInsideBounds position.x 
                y = bringInsideBounds position.y }
            HitABarrier,newPos
        else
            MoveOk,position

    // note that state is LAST param in all these functions

    let move log distance state =
        log (sprintf "Move %0.1f" distance)
        // calculate new position 
        let newPosition = calcNewPosition distance state.angle state.position 
        // adjust the new position if out of bounds
        let moveResult, newPosition = checkPosition newPosition 
        // draw line if needed
        if state.penState = Down then
            dummyDrawLine log state.position newPosition state.color
        // return the new state and the Move result
        let newState = {state with position = newPosition}
        (moveResult,newState) 

    let turn log angle state =
        log (sprintf "Turn %0.1f" angle)
        // calculate new angle
        let newAngle = (state.angle + angle) % 360.0<Degrees>
        // update the state
        {state with angle = newAngle}

    let penUp log state =
        log "Pen up" 
        {state with penState = Up}

    let penDown log state =
        log "Pen down" 
        {state with penState = Down}

    let setColor log color state =
        let colorResult = 
            if color = Red then OutOfInk else ColorOk
        log (sprintf "SetColor %A" color)
        // return the new state and the SetColor result
        let newState = {state with color = color}
        (colorResult,newState)