fold.ml

let (=>) left right = print_char (if left = right then '.' else 'F')

open Printf
let id x = x
let const x = fun _ -> x
let sum = List.fold_left (+) 0
let (>>) f g x = g (f x)


let () =
  List.fold_right (^) ["a"; "b"; "c"] "z" => ("a" ^ ("b" ^ ("c" ^ "z")))

let () =
  List.fold_left (^) "z" ["a"; "b"; "c"] => ((("z" ^ "a") ^ "b") ^ "c")

let () =
  let open StdLabels in
  List.fold_right ~f:(+) ~init:0 [1; 2; 3; 4] => (1 + (2 + (3 + (4 + 0))))

let () =
  let open StdLabels in
  List.fold_left ~f:(+) ~init:0 [1; 2; 3; 4] => ((((0 + 1) + 2) + 3) + 4)

let rec fold_right ~f ~init = function
  | [] -> init
  | head :: tail -> f head (fold_right ~f ~init tail)



let nil = []
let cons head tail = head :: tail

let rec fold ~nil ~cons = function
  | [] -> nil
  | head :: tail -> cons head (fold ~nil ~cons tail)





module Tree = struct
  type 'a t = Leaf of 'a | Node of 'a t * 'a t

  let rec fold ~leaf ~node = function
    | Leaf a -> leaf a
    | Node (left, right) ->
        node (fold ~leaf ~node left) (fold ~leaf ~node right)

  let leaf a = Leaf a
  let node left right = Node (left, right)

  let size = fold ~leaf:(const 1) ~node:(+)

  let height = fold ~leaf:(const 1) ~node:(fun l r -> 1 + max l r)

  let to_string leaf = fold ~leaf ~node:(sprintf "(%s %s)")
  let reverse = fold ~leaf ~node:(fun l r -> node r l)
  let map f = fold ~leaf:(f >> leaf) ~node
  let bind f = fold ~leaf:f ~node
  let iter f = fold ~leaf:f ~node:(fun _ _ -> ())
  let for_all predicate = fold ~leaf:predicate ~node:(&&)
  let exists predicate = fold ~leaf:predicate ~node:(||)

  let rec fold_right ~f ~init = function
    | Leaf a -> f a init
    | Node (left, right) ->
        fold_right ~f ~init:(fold_right ~f ~init right) left

  let to_list = fold_right ~f:List.cons ~init:[]
  let map_to_list f = fold_right ~f:(f >> List.cons) ~init:[]
end

open Tree

let ab = Node (Leaf "a", Leaf "b")
let cd = Node (Leaf "c", Leaf "d")
let aa = Node (Leaf "a", Leaf "a")
let ab_cd = Node (ab, cd)

let to_string = Tree.to_string id

module TestBinTree = struct
  Tree.size ab_cd => 4;

  Tree.height ab_cd => 3;
  Tree.height ab => 2;
  Tree.height (leaf "a") => 1;

  to_string ab_cd => "((a b) (c d))";

  to_string (Tree.reverse ab_cd) => "((d c) (b a))";

  Tree.iter (printf "%s") ab_cd;

  to_string (Tree.map String.uppercase_ascii ab_cd) => "((A B) (C D))";

  Tree.for_all ((=) "a") ab_cd => false;
  Tree.for_all ((=) "a") aa => true;

  Tree.to_list ab_cd => ["a"; "b"; "c"; "d"];
  Tree.map_to_list String.uppercase_ascii ab_cd
    => ["A"; "B"; "C"; "D"];
end






module Syntax = struct
  type t =
    | Unit
    | Boolean of bool
    | Number of int
    | Id of string
    | Divide of t * t
    | Sequence of t * t
    | Let of {id: string; value: t; body: t}
    | If of if_
  and if_ = {conditional: t; consequence: t; alternative: t}

  let unit = Unit
  let boolean b = Boolean b
  let number n = Number n
  let id i = Id i
  let divide dividend divisor = Divide (dividend, divisor)
  let sequence first second = Sequence (first, second)
  let let_ id value body = Let {id; value; body}
  let if_ x = If x

  let rec fold ~unit ~boolean ~number ~id ~divide ~sequence ~let_ ~if_ = function
    | Unit -> unit
    | Boolean b -> boolean b
    | Number n -> number n
    | Id i -> id i
    | Divide (dividend, divisor) -> divide dividend divisor
    | Sequence (first, second) ->
        let fold' = fold ~unit ~boolean ~number ~id ~divide ~sequence ~let_ ~if_ in
        sequence (fold' first) (fold' second)
    | Let {id=id'; value; body} ->
        let fold' = fold ~unit ~boolean ~number ~id ~divide ~sequence ~let_ ~if_ in
        let_ id' (fold' value) (fold' body)
    | If {conditional; consequence; alternative} ->
        let fold' = fold ~unit ~boolean ~number ~id ~divide ~sequence ~let_ ~if_ in
        let conditional = fold' conditional in
        let consequence = fold' consequence in
        let alternative = fold' alternative in
        if_ {conditional; consequence; alternative}

  let map f =
    fold ~unit ~boolean ~number ~id
      ~divide:(fun l r -> divide (f l) (f r))
      ~sequence:(fun l r -> sequence (f l) (f r))
      ~let_:(fun id value body -> let_ id (f value) (f body))
      ~if_:(fun {conditional; consequence; alternative} ->
            if_ {conditional=f conditional;
                 consequence=f consequence;
                 alternative=f alternative})

end


module Dead_code_elimination = struct
  open Syntax

  let rec pass = function
    | If {conditional=Boolean true; consequence; _} ->
        pass consequence
    | If {conditional=Boolean false; alternative; _} ->
        pass alternative
    | other -> map pass other
end

module Dead_code_elimination_2 = struct
  open Syntax

  let pass =
    fold ~unit ~boolean ~number ~id ~divide ~sequence ~let_ ~if_:(function
      | {conditional=Boolean true; consequence; _} -> consequence
      | {conditional=Boolean false; alternative; _} -> alternative
      | other -> If other)

end

module Dead_code_elimination_3 = struct
  open Syntax

  let fold' =
    fold ~unit ~boolean ~number ~id ~divide ~sequence ~let_

  let pass =
    fold' ~if_:(function
      | {conditional=Boolean true; consequence; _} ->
          consequence
      | {conditional=Boolean false; alternative; _} ->
          alternative
      | other -> If other)
end