silly phrase generator thing

phrases.ml

(** Phrase generator based on an example from the Grammatical Framework tutorial.

  - {{:https://okmij.org/ftp/gengo/NASSLLI10/}
    Lambda: the ultimate syntax-semantics interface}
  - {{:https://www.grammaticalframework.org/doc/tutorial/gf-tutorial.html#toc16}
    Grammatical Framework Tutorial: Lesson 2}

  Todo:

  - generate languages (orthographies, vacabularies, grammars)
  - generate other phrases
    - landform descriptions
    - place names
    - house/village descriptions
    - character descriptions
*)

(* Sample output:
    $ food --seed "...." | head --lines 20
    this very fresh muffin is delicious
    this fairybread is warm
    this fresh pikelet is very very boring
    the porridge is warm
    this cabbage is warm
    this lamington is delicious
    that muffin is delicious
    this dumpling is delicious
    this lamington is delicious
    that crumpet is fresh
    the pudding is expensive
    that dumpling is bland
    this delicious pikelet is bland
    that delicious crumpet is fresh
    that lamington is bland
    that lamington is boring
    this fairybread is sweet
    this pudding is fresh
    the bland cabbage is bland
    the sandwich is sweet
*)

module Cat = struct
  (** Syntactic Categories *)

  type phrase = |
  type item = |
  type kind = |
  type quality = |

end

module type Food = sig
  (** Syntax-semantics interface for phrases about food *)

  open Cat

  type _ repr

  (** Phrases *)

  val is : item repr -> quality repr -> phrase repr

  (** Items *)

  val that : kind repr -> item repr
  val the : kind repr -> item repr
  val this : kind repr -> item repr

  (** Kinds *)

  val qkind : quality repr -> kind repr -> kind repr

  val cabbage : kind repr
  val crumpet : kind repr
  val custard : kind repr
  val dumpling : kind repr
  val fairybread : kind repr
  val lamington : kind repr
  val muffin : kind repr
  val pikelet : kind repr
  val porridge : kind repr
  val pudding : kind repr
  val sandwich : kind repr

  (** Qualities *)

  val very : quality repr -> quality repr

  val bland : quality repr
  val boring : quality repr
  val delicious : quality repr
  val expensive : quality repr
  val fresh : quality repr
  val sweet : quality repr
  val warm : quality repr

end

(** English food phrases *)
module FoodEn : Food

  with type _ repr = string

= struct

  type _ repr = string

  let ( ++ ) x y = x ^ " " ^ y

  let is item quality = item ++ "is" ++ quality

  let that kind = "that" ++ kind
  let the kind = "the" ++ kind
  let this kind = "this" ++ kind

  let qkind quality kind = quality ++ kind

  let cabbage = "cabbage"
  let crumpet = "crumpet"
  let custard = "custard"
  let dumpling = "dumpling"
  let fairybread = "fairybread"
  let lamington = "lamington"
  let muffin = "muffin"
  let pikelet = "pikelet"
  let porridge = "porridge"
  let pudding = "pudding"
  let sandwich = "sandwich"

  let very quality = "very" ++ quality

  let bland = "bland"
  let boring = "boring"
  let delicious = "delicious" (* | "tasty" *) (* TODO: synonyms *)
  let expensive = "expensive"
  let fresh = "fresh"
  let sweet = "sweet"
  let warm = "warm"

end

module Gen : sig
  (** Random value generators. *)

  type 'a t
  (** The representation of random value generators. *)


  (** {1 Monadic API} *)

  val pure : 'a -> 'a t
  (** [pure x] is a generator that always returns [x]. *)

  val map : ('a -> 'b) -> 'a t -> 'b t
  (* TODO: Docs *)

  val app : ('a -> 'b) t -> 'a t -> 'b t
  (** [app f x] effectfully applies [f] to [x] *)

  val bind : 'a t -> ('a -> 'b t) -> 'b t
  (* TODO: Docs *)

  val seq : 'a t -> 'b t -> ('a * 'b) t
  (** [seq x y] performs two effectful operations [x] and [y], and returns the
      result as a pair. *)

  val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
  val map3 : ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t

  val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
  val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t
  val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
  val ( and* ) : 'a t -> 'b t -> ('a * 'b) t


  (** {1 Generators} *)

  val int : start:int -> stop:int -> int t
  (** [int ~start ~stop] generates an integer between [start] (inclusive) and
      [stop] (exclusive). *)

  val float : start:float -> stop:float -> float t
  (** [float ~start ~stop] generates a float between [start] and [stop]. *)

  val one_of : 'a t array -> 'a t
  (** [one_of xs] generates a value using a randomly selected a generator in [xs]. *)

  val one_of_freq : (int * 'a t) array -> 'a t
  (** [one_of_freq xs] generates a value using a randomly selected a generator
      in [xs], distributed using the supplied frequencies. *)

  val repeat : 'a t -> 'a Seq.t t
  (** [repeat x] generates an infinite sequence of random values using [x]. *)

  val delay : (unit -> 'a t) -> 'a t
  (** [delay f] delays the execution of [f] until the generator is actually
      used. This can be used to implement recursive generators without looping
      forever. *)


  (** {1 Running generators} *)

  val run : Random.State.t -> 'a t -> 'a
  (** [run state x] runs the generator [x] using [state]  *)

end = struct

  type 'a t = Random.State.t -> 'a

  let pure x =
    fun _ -> x

  let map f x =
    fun state -> f (x state)

  let app f x =
    fun state -> (f state) (x state)

  let bind x f =
    fun state -> f (x state) state

  let seq x y =
    app (map (fun x y -> x, y) x) y

  let map2 f x y =
    app (map f x) y

  let map3 f x y z =
    app (app (map f x) y) z

  let ( let+ ) x f = map f x
  let ( let* ) = bind
  let ( and+ ) = seq
  let ( and* ) = seq

  let int ~start ~stop =
    fun state ->
      start + Random.State.int state (stop - start)

  let float ~start ~stop =
    fun state ->
      start +. Random.State.float state (stop -. start)

  let one_of xs =
    let* i = int ~start:0 ~stop:(Array.length xs) in
    Array.get xs i

  let one_of_freq xs =
    let rec go target_freq total_freq i =
      let freq, x = Array.get xs i in
      if target_freq < total_freq + freq then x else
        (go [@tailcall]) target_freq (total_freq + freq) (i + 1)
    in
    let total = Array.fold_left (fun total (f, _) -> total + f) 0 xs in
    let* target_freq = int ~start:0 ~stop:total in
    go target_freq 0 0

  let repeat x =
    fun state ->
      Seq.of_dispenser (fun () -> Some (x state))

  let delay f =
    fun state -> f () state

  let run state x =
    x state

end

(** Random phrase generator *)
module GenFood (F : Food) : sig

  val phrase : Cat.phrase F.repr Gen.t

end = struct

  open Gen

  let rec quality () =
    one_of_freq [|
      2, map F.very (delay quality);
      1, pure F.bland;
      1, pure F.boring;
      1, pure F.delicious;
      1, pure F.expensive;
      1, pure F.fresh;
      1, pure F.sweet;
      1, pure F.warm;
    |]

  let rec kind () =
    one_of_freq [|
      2, map2 F.qkind (delay quality) (delay kind);
      1, pure F.cabbage;
      1, pure F.crumpet;
      1, pure F.custard;
      1, pure F.dumpling;
      1, pure F.fairybread;
      1, pure F.lamington;
      1, pure F.muffin;
      1, pure F.pikelet;
      1, pure F.porridge;
      1, pure F.pudding;
      1, pure F.sandwich;
    |]

  let item () =
    one_of [|
      map F.that (delay kind);
      map F.the (delay kind);
      map F.this (delay kind);
    |]

  let phrase =
    map2 F.is (delay item) (delay quality)

end

module GenFoodEn = GenFood (FoodEn)

let usage name =
  Format.printf "Usage:\n";
  Format.printf "  %s [--seed SEED]\n" (Filename.basename name);
  Format.printf "  %s (-h | --help)\n" (Filename.basename name)

let run ?(state = Random.State.make_self_init ()) () =
  Gen.repeat GenFoodEn.phrase
    |> Gen.run state
    |> Seq.iter print_endline

let () =
  match Array.to_list Sys.argv with
  | [_] -> run ()
  | [_; "--seed"; seed] ->
      let seed =
        String.to_seq seed
          |> Seq.map Char.code
          |> Array.of_seq
      in
      run ~state:(Random.State.make seed) ()
  | [name; "-h"] | [name; "--help"] -> usage name
  | name :: _ -> usage name; exit 1
  | [] -> failwith "impossible"