lindenmayer_systems.ml

(** Fractal binary trees

    L-systems are a really wonderful model of plant growth, showing how a set of
    simple grammar rules can result in incredibly life-like and complicated
    organic forms.

    They do however seem a little… stuck in the 80s? In L-systems the state of a
    plant is modelled as a list of instructions, where the branching structure
    emerges from an imperative interpretation of “push” and “pop” symbols. For
    example an L-system that describes a fractal binary tree looks like this:

    {v
      grammar stem {

        terminals :=
          | bud
          | internode

        non-terminals :=
          | [
          | ]

        axiom := Bud

        rules :=
          | internode -> internode internode
          | bud -> internode [ bud ] bud

      }
    v}

    I’m interested in bringing more PL-ideas to L-systems, where the underlying
    tree structure is preserved in the plant model. For example, a binary tree
    might look like this:

    {v
      grammar stem {

        symbol stem :=
          | bud
          | node(stem, stem)
          | internode(stem)

        axiom := bud

        rules :=
          | internode(...) -> internode(internode(...))
          | bud -> internode(node(bud, bud))

      }
    v}
*)

(** Interesting reading on L-systems and coalgebras:

    - {{:https://coalg.org/cmcs12/slides/baltasar_winter.pdf} Lindenmayer Systems, Coalgebraically}
    - {{:https://web.archive.org/web/20221205050615/http://reinh.com/notes/posts/2015-06-27-theoretical-pearl-l-systems-as-final-coalgebras.html}
      Theoretical Pearl: L-systems as Final Coalgebras}
*)

module Traditional = struct
  (** A traditional, bracketed L-system that models a fractal binary tree.

      From the {{:https://en.wikipedia.org/wiki/L-system#Example_2:_Fractal_(binary)_tree}
      L-system page} on Wikipedia.

      {v
        grammar stem {

          terminals :=
            | bud
            | internode

          non-terminals :=
            | [
            | ]

          axiom := Bud

          rules :=
            | internode -> internode internode
            | bud -> internode [ bud ] bud

        }
      v}

      For plant terminology, see {{:https://en.wikipedia.org/wiki/Plant_stem}
      Plant stem} on Wikipedia.

      This should form the following tree:

      {v
         oo  oo oo  oo
       oo  \ /   \ /  oo
         \__|     |__/
         /   \   /   \
       oo     \ /     oo
               |
               |

        o - bud
        / - internode
      v}

      The nesting of the branches is defined in terms of paired [\[] and [\]]
      symbols, which can be translated straightforwardly into imperative turtle
      drawing commands.

      Note that this makes implementing context-sensitive L-systems rather
      challenging, as the L-system needs to know about the nesting of the
      non-terminals.
  *)

  type nonterm =
    | Bud
    | Internode

  type term =
    | Push
    | Pop

  type symbol = (nonterm, term) Either.t
  type word = symbol list

  let axiom : word = [Left Bud]

  let rules : nonterm -> word  =
    function
    (* Grow the internode by duplicating it:

                /
        /  ->  /
    *)
    | Internode ->
        [
          Left Internode;
          Left Internode;
        ]

    (* Divide a bud into an internode and two buds:

               oo
       o  ->  /
    *)
    | Bud ->
        [
          Left Internode;
          Right Push;
          Left Bud;
          Right Pop;
          Left Bud;
        ]

  let step =
    List.concat_map
      (function
        | Either.Left nt -> rules nt
        | Either.Right t -> [Right t])

  let generate axiom =
    Seq.unfold (fun word -> Some (word, step word)) axiom

end

module Structured = struct
  (** Attempt at a structured L-System(?), that uses trees instead of lists of
      instructions to represent nested structures.

      This can be easily drawn using a {{:diagrams} https://diagrams.github.io/}-style
      graphics API, where scoped transformations are applied based on the
      nesting of drawing expressions.

      Context-sensitive L-systems might need to use zippers to have access to
      the surrounding context of the tree, allowing for {i acropetal} and
      {i basipetal} signalling (see section 1.8 of {i The Algorithmic Beauty of
      Plants}).

      {v
        grammar stem {

          symbol stem :=
            | bud
            | node(stem, stem)
            | internode(stem)

          axiom := bud

          rules :=
            | internode(...) -> internode(internode(...))
            | bud -> internode(node(bud, bud))

        }
      v}
  *)

  type stem =
    | Bud
    | Node of stem * stem
    | Internode of stem

  let axiom = Bud

  let rec rules =
    function
    | Internode stem -> Internode (Internode (rules stem))
    | Bud -> Internode (Node (Bud, Bud))
    | Node (stem1, stem2) -> Node (rules stem1, rules stem2)

  let generate axiom =
    Seq.unfold (fun stem -> Some (stem, rules stem)) axiom

end

(** Compile the nested tree representation to a list of instructions *)
let rec compile : Structured.stem -> Traditional.word =
  let open Either in
  let open Traditional in
  function
  | Bud -> [Left Bud]
  | Node (stem1, stem2) -> [Right Push] @ compile stem1 @ [Right Pop] @ compile stem2
  | Internode stem -> [Left Internode] @ compile stem

lindenmayer_systems_catamorphisms.ml

(** Experimenting with ways of cleaning up recursive rule applications and
    boilerplate patterns, inspired by the {{:https://docs.racket-lang.org/nanopass/index.html#%28part._cata-morphism%29}
    catamorphisms} and {{:https://docs.racket-lang.org/nanopass/index.html#(part._.Auto-generated_clauses)}
    auto-generated clauses} found in the Nanopass Framework.

    Further thought will be needed if we want to make the patterns on the LHS of
    rules more powerful (for example with context-sensitive rules). This is just
    to get a feeling for what a dedicated language might be able to support.
*)

module StructuredFoldRecord = struct
  (** Using {{:catamorphisms} https://en.wikipedia.org/wiki/Catamorphism} to
      automate recursive rule applications. *)

  (** {1 Syntax} *)

  type stem =
    | Bud
    | Node of stem * stem
    | Internode of stem

  (** {2 Annoying boilerplate} *)

  type 'out stem_algebra = {
    bud : 'out;
    node : 'out * 'out -> 'out;
    internode : 'out -> 'out;
  }

  let rec fold (alg : 'out stem_algebra) : stem -> 'out =
    function
    | Bud -> alg.bud
    | Node (s1, s2) -> alg.node (fold alg s1, fold alg s2)
    | Internode s -> alg.internode s

  (** {1 Grammar} *)

  let rules = {
    bud = Internode (Node (Bud, Bud));
    node = (fun (s1, s2) -> Node (s1, s2)); (* we shouldn’t have to write this case! *)
    internode = (fun s -> Internode (Internode s));
    (*                                         ^ note that we no longer need to call the rules recursively *)
  }

  let generate axiom =
    Seq.unfold (fun stem -> Some (stem, fold rules stem)) axiom

end

(** The following experiments are related to trying to avoid boilerplate
    patterns, like in Nanopass’ {{:https://docs.racket-lang.org/nanopass/index.html#(part._.Auto-generated_clauses)}
    auto-generated clauses}. *)

module StructuredFoldObject = struct
  (** Using objects to allow boiler-plate patterns to be omitted. *)

  (** {1 Syntax} *)

  type stem =
    | Bud
    | Node of stem * stem
    | Internode of stem

  (** {2 Annoying boilerplate} *)

  type 'out stem_algebra = <
    bud : 'out;
    node : 'out -> 'out -> 'out;
    internode : 'out -> 'out;
  >

  class initial_stem_algebra = object
    method bud : stem = Bud
    method node (s1 : stem) (s2 : stem) : stem = Node (s1, s2)
    method internode (s : stem) : stem = Internode s
  end

  let rec fold (alg : 'out stem_algebra) : stem -> 'out =
    function
    | Bud -> alg#bud
    | Node (s1, s2) -> alg#node (fold alg s1) (fold alg s2)
    | Internode s -> alg#internode (fold alg s)


  (** {1 Grammar} *)

  let axiom = Bud

  let[@warning "-method-override"] rules = object

    inherit initial_stem_algebra

    method bud = Internode (Node (Bud, Bud))
    method internode s = Internode (Internode s)

  end

  let generate axiom =
    Seq.unfold (fun stem -> Some (stem, fold rules stem)) axiom

end

module StructuredFoldModule = struct
  (** Using first-class modules to allow boiler-plate patterns to be omitted. *)

  (** {1 Syntax} *)

  type stem =
    | Bud
    | Node of stem * stem
    | Internode of stem

  (** {2 Annoying boilerplate} *)

  module StemAlgebra = struct

    module type S = sig

      type out

      val bud : out
      val node : out -> out -> out
      val internode : out -> out

    end

    module Initial : S with type out = stem = struct

      type out = stem

      let bud : stem = Bud
      let node (s1 : stem) (s2 : stem) : stem = Node (s1, s2)
      let internode (s : stem) : stem = Internode s

    end

    let fold (type out) (module A : S with type out = out) : stem -> out =
      let rec go =
        function
        | Bud -> A.bud
        | Node (s1, s2) -> A.node (go s1) (go s2)
        | Internode s -> A.internode (go s)
      in
      go

  end


  (** {1 Grammar} *)

  let axiom = Bud

  module Rules : StemAlgebra.S with type out = stem = struct

    include StemAlgebra.Initial

    let bud = Internode (Node (Bud, Bud))
    let internode s = Internode (Internode s)

  end

  let generate axiom =
    Seq.unfold (fun stem -> Some (stem, StemAlgebra.fold (module Rules) stem)) axiom

end