9 people like it.

Interact monad

Interactive computation that asks the user questions

  1: 
  2: 
  3: 
  4: 
  5: 
  6: 
  7: 
  8: 
  9: 
 10: 
 11: 
 12: 
 13: 
 14: 
 15: 
 16: 
 17: 
 18: 
 19: 
 20: 
 21: 
 22: 
 23: 
 24: 
 25: 
 26: 
 27: 
 28: 
 29: 
 30: 
 31: 
 32: 
 33: 
 34: 
 35: 
 36: 
 37: 
 38: 
 39: 
 40: 
 41: 
 42: 
 43: 
 44: 
 45: 
 46: 
 47: 
 48: 
 49: 
 50: 
 51: 
 52: 
 53: 
 54: 
 55: 
 56: 
 57: 
 58: 
 59: 
 60: 
 61: 
 62: 
 63: 
 64: 
 65: 
 66: 
 67: 
 68: 
 69: 
 70: 
 71: 
 72: 
 73: 
 74: 
 75: 
 76: 
 77: 
 78: 
 79: 
 80: 
 81: 
 82: 
 83: 
 84: 
 85: 
 86: 
 87: 
 88: 
 89: 
 90: 
 91: 
 92: 
 93: 
 94: 
 95: 
 96: 
 97: 
 98: 
 99: 
100: 
101: 
102: 
103: 
104: 

type Color = Pink | Purple

type Interactive<'R> = 
  | Done of 'R
  | WhatColor of (Color -> Interactive<'R>)
  | WhatNumber of (int -> Interactive<'R>)

let unitInt v = Done v

let rec bindInt (f:'a -> Interactive<'b>) (comp:Interactive<'a>) =
  match comp with 
  | Done v -> f v
  | WhatColor g -> WhatColor(fun c -> bindInt f (g c))
  | WhatNumber g -> WhatNumber(fun c -> bindInt f (g c))

let getColor = WhatColor(fun c -> unitInt c)
let getNumber = WhatNumber(fun n -> unitInt n)

let demo =
  getColor |> bindInt (fun c1 -> 
    getColor |> bindInt (fun c2 -> 
      getNumber |> bindInt (fun n ->
        unitInt (List.init n (fun _ -> c1 = c2))
  )))


let rec run c = 
  match c with 
  | Done v -> v
  | WhatNumber f ->
      let input = System.Console.ReadLine()
      run (f (int input))
  | WhatColor f ->
      let input = System.Console.ReadLine()
      if input = "pink" then run (f Pink)
      elif input = "purple" then run (f Purple)
      else failwith "wrong input"

//run demo |> printfn "Got %A"

// --------------------------------------------------------------------------

(*
module Haskell =
  type Question = 

  type InteractiveSt<'S, 'R> = 
    | Done of 'R
    | What of \exists 'Q such that 'Q is question. ('Q -> State<'S, 'R>)

  and State<'S, 'R> = St of ('S -> 'S * InteractiveSt<'S, 'R>)
*)

type InteractiveSt<'S, 'R> = 
  | Done of 'R
  | WhatColor of (Color -> State<'S, 'R>)
  | WhatNumber of (int -> State<'S, 'R>)

and State<'S, 'R> = St of ('S -> 'S * InteractiveSt<'S, 'R>)

let unitSt v = St(fun s -> s, Done(v))

let rec bindSt (f:'a -> State<'s, 'b>) (comp:State<'s, 'a>) : State<'s, 'b> = St(fun s ->
  let (St g1) = comp
  let s, ia = g1 s
  match ia with 
  | Done v -> 
      let (St g2) = f v
      let (s, ib) = g2 s
      s, ib
  | WhatColor g -> 
      s, WhatColor(fun c -> bindSt f (g c))
  | WhatNumber g -> 
      s, WhatNumber (fun n -> bindSt f (g n))
)

let getColorSt() = St(fun s -> s, WhatColor(fun c -> St(fun s -> s, Done(c))))
let getNumberSt() = St(fun s -> s, WhatNumber(fun n -> St(fun s -> s, Done(n))))
let getState() = St(fun s -> s, Done s)
let setState ns = St(fun _ -> ns, Done ())

let demo2 : State<Color list, bool list> =
  getState () |> bindSt (fun s ->
    getColorSt () |> bindSt (fun c1 -> 
      getColorSt () |> bindSt (fun c2 -> 
        getNumberSt () |> bindSt (fun n ->
          setState (c1::c2::s) |> bindSt (fun () ->
            unitSt (List.init n (fun _ -> c1 = c2))
    )))))


let rec runSt (St c) s = 
  match c s with 
  | s, Done v -> s, v
  | s, WhatNumber f ->
      let input = System.Console.ReadLine()
      runSt (f (int input)) s
  | s, WhatColor f ->
      let input = System.Console.ReadLine()
      if input = "pink" then runSt (f (Pink)) s
      elif input = "purple" then runSt (f (Purple)) s
      else failwith "wrong input"

runSt demo2 [Pink] |> printfn "Got %A"
union case Color.Pink: Color
union case Color.Purple: Color
type Interactive<'R> =
  | Done of 'R
  | WhatColor of (Color -> Interactive<'R>)
  | WhatNumber of (int -> Interactive<'R>)
union case Interactive.Done: 'R -> Interactive<'R>
union case Interactive.WhatColor: (Color -> Interactive<'R>) -> Interactive<'R>
type Color =
  | Pink
  | Purple
union case Interactive.WhatNumber: (int -> Interactive<'R>) -> Interactive<'R>
Multiple items
val int : value:'T -> int (requires member op_Explicit)

--------------------
[<Struct>]
type int = int32

--------------------
type int<'Measure> =
  int
val unitInt : v:'a -> Interactive<'a>
val v : 'a
val bindInt : f:('a -> Interactive<'b>) -> comp:Interactive<'a> -> Interactive<'b>
val f : ('a -> Interactive<'b>)
val comp : Interactive<'a>
val g : (Color -> Interactive<'a>)
val c : Color
val g : (int -> Interactive<'a>)
val c : int
val getColor : Interactive<Color>
val getNumber : Interactive<int>
val n : int
val demo : Interactive<bool list>
val c1 : Color
val c2 : Color
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
    interface IReadOnlyList<'T>
    interface IReadOnlyCollection<'T>
    interface IEnumerable
    interface IEnumerable<'T>
    member GetReverseIndex : rank:int * offset:int -> int
    member GetSlice : startIndex:int option * endIndex:int option -> 'T list
    static member Cons : head:'T * tail:'T list -> 'T list
    member Head : 'T
    member IsEmpty : bool
    member Item : index:int -> 'T with get
    ...
val init : length:int -> initializer:(int -> 'T) -> 'T list
val run : c:Interactive<'a> -> 'a
val c : Interactive<'a>
val f : (int -> Interactive<'a>)
val input : string
namespace System
type Console =
  static member Beep : unit -> unit + 1 overload
  static member CheckNonNull : obj: obj * paramName: string -> unit
  static member Clear : unit -> unit
  static member CreateOutputWriter : outputStream: Stream -> TextWriter
  static member EnsureInitialized<'T (requires reference type)> : field: byref<'T> * initializer: Func<'T> -> 'T
  static member HandleBreakEvent : controlKey: ConsoleSpecialKey -> bool
  static member MoveBufferArea : sourceLeft: int * sourceTop: int * sourceWidth: int * sourceHeight: int * targetLeft: int * targetTop: int -> unit + 1 overload
  static member OpenStandardError : unit -> Stream + 1 overload
  static member OpenStandardInput : unit -> Stream + 1 overload
  static member OpenStandardOutput : unit -> Stream + 1 overload
  ...
System.Console.ReadLine() : string
val f : (Color -> Interactive<'a>)
val failwith : message:string -> 'T
type InteractiveSt<'S,'R> =
  | Done of 'R
  | WhatColor of (Color -> State<'S,'R>)
  | WhatNumber of (int -> State<'S,'R>)
union case InteractiveSt.Done: 'R -> InteractiveSt<'S,'R>
union case InteractiveSt.WhatColor: (Color -> State<'S,'R>) -> InteractiveSt<'S,'R>
type State<'S,'R> = | St of ('S -> 'S * InteractiveSt<'S,'R>)
union case InteractiveSt.WhatNumber: (int -> State<'S,'R>) -> InteractiveSt<'S,'R>
union case State.St: ('S -> 'S * InteractiveSt<'S,'R>) -> State<'S,'R>
val unitSt : v:'a -> State<'b,'a>
val s : 'b
val bindSt : f:('a -> State<'s,'b>) -> comp:State<'s,'a> -> State<'s,'b>
val f : ('a -> State<'s,'b>)
val comp : State<'s,'a>
val s : 's
val g1 : ('s -> 's * InteractiveSt<'s,'a>)
val ia : InteractiveSt<'s,'a>
val g2 : ('s -> 's * InteractiveSt<'s,'b>)
val ib : InteractiveSt<'s,'b>
val g : (Color -> State<'s,'a>)
val g : (int -> State<'s,'a>)
val getColorSt : unit -> State<'a,Color>
val s : 'a
val getNumberSt : unit -> State<'a,int>
val getState : unit -> State<'a,'a>
val setState : ns:'a -> State<'a,unit>
val ns : 'a
val demo2 : State<Color list,bool list>
type 'T list = List<'T>
[<Struct>]
type bool = System.Boolean
val s : Color list
val runSt : State<'a,'b> -> s:'a -> 'a * 'b
val c : ('a -> 'a * InteractiveSt<'a,'b>)
val v : 'b
val f : (int -> State<'a,'b>)
val f : (Color -> State<'a,'b>)
val printfn : format:Printf.TextWriterFormat<'T> -> 'T
Raw view Test code New version

More information

Link:http://fssnip.net/8ay
Posted:6 months ago
Author:Tomas Petricek
Tags: monad

This web site is created using F# and Suave web server. It is hosted on Azure and the source code is on GitHub. Contributions are welcome!

The first version of fssnip.net has been created by @tomaspetricek back in 2010. This web site is a new, open-source and contribution-friendly version.