type op = char * (int -> int -> int)

let plus = '+',(+)
let times = '*',( * )
let minus = '-',(-)

type expr =
  | I of int
  | Op of op * expr * expr

let t0 =
  Op (plus,
      Op (minus,
          Op (plus, Op (times, I 2, I 12), I 7),
          I 42),
      Op (plus, I 11, I 5))

let rec eval = function
  | I i -> i
  | Op (o,a,b) -> (snd o) (eval a) (eval b)

let rec pp_expr ch = function
  | I i -> Format.fprintf ch "%d" i
  | Op (o,a,b) -> Format.fprintf ch "(%a%c%a)" pp_expr a (fst o) pp_expr b

let rec pp_list pp ch = function
  | [] -> ()
  | [a] -> pp ch a
  | a::b::more -> Format.printf "%a, %a" pp a (pp_list pp) (b::more)

let () = Format.printf "Exemple:\n %a\n" (pp_list pp_expr) [t0]
let () = assert (eval t0 = 5)

(** Ci-dessous divers arbres sur lesquels tester le code. *)

(** Beaucoup de solutions. *)
let t1 =
  Op (plus, I 41,
      Op (plus, I 9,
          Op (plus, I 12,
              Op (plus, I 8,
                  Op (plus, I 25, I 55)))))

(** Nettement plus contraignant. *)
let t2 =
  Op (times, I 41,
      Op (times, I 9,
          Op (plus, I 12,
              Op (times, I 8,
                  Op (times, I 25, I 55)))))

(** Une seule solution avec embedded. *)
let t3 =
  Op (times, I 16,
      Op (minus, I 64,
          Op (plus, I 42, I 12)))

(** Trop de solutions pour les afficher. *)
let t4 = Op (plus, I 25, t1)

(** L'arbre utilisé comme test dans la suite. *)
let t = t3


(** Ecriture des itérateurs subtree et embedded en style direct. *)
module Un = struct

  let rec subtree t f =
    match t with
      | I i -> f (I i)
      | Op (o,a,b) ->
          f t ;
          subtree a f ;
          subtree b f

  let count iter =
    let n = ref 0 in
      iter (fun _ -> incr n) ;
      !n

  let until_nth iter f n =
    let n = ref n in
      try
        iter (fun i -> decr n ; f i ; if !n = 0 then raise Exit)
      with Exit -> ()

  let () = Format.printf "Nombre de sous-expr: %d\n" (count (subtree t))
  let () = until_nth (subtree t) (Format.printf " %a\n" pp_expr) 7

  (* Pour chaque sous-arbre de a, on le remonte,
   * puis on le combine avec chaque sous-arbre de b.
   * Enfin on énumère les sous-arbres de b en isolation. *)
  let rec embedded t f =
    match t with
      | I _ -> f t
      | Op (o,a,b) ->
          embedded a
            (fun a' ->
               f a' ;
               embedded b
                 (fun b' ->
                    f (Op (o,a',b')))) ;
          embedded b f

  let () = Format.printf "Nombre de embed-expr: %d\n" (count (embedded t))
  let () = until_nth (embedded t) (Format.printf " %a\n" pp_expr) 7

end

(** Passage sous forme ENUM et utilisation pour chercher des séquences
  * dont la somme des valeurs fasse 100. *)
module Deux = struct

  module type ENUM = sig
    type t
    type collection
    type elt

    val init : collection -> t
    val next : t -> (elt*t) option

    val eval : elt -> int
    val pp : Format.formatter -> elt -> unit
  end

  module Find (E:ENUM with type collection = expr) = struct

    open E

    let rec iter t f =
      let rec aux it cur target =
        if target = 0 then
          f cur
        else
          match next it with
            | None -> ()
            | Some (t,it) ->
                let e = eval t in
                  aux it cur target ;
                  if e > 0 && e <= target then
                    aux it (t::cur) (target-e)
      in
        aux (E.init t) [] 100

  end

  let rec count it next =
    let rec aux it n =
      match next it with
        | Some (_,it) -> aux it (n+1)
        | None -> n
    in
      aux it 0

  let until_nth it next f max =
    let rec aux it n =
      if n<=max then
        match next it with
          | Some (i,it) -> f i ; aux it (n+1)
          | None -> ()
    in
      aux it 0

  module Test (E:ENUM with type collection = expr) = struct

    let () = Format.printf "\n### Test ###\n"

    let () =
      Format.printf "Nombre d'elements: %d\n" (count (E.init t) E.next) ;
      Format.printf "10 premiers:\n" ;
      until_nth (E.init t) E.next (Format.printf " %a\n" E.pp) 10

    let () =
      let module F = Find(E) in
      let count = ref 0 in
        Format.printf "Solutions à somme 100:\n" ;
        F.iter t
          (fun t ->
             incr count ;
             Format.printf " %03d: %a\n" !count (pp_list E.pp) t)

  end

  (** Itérateur sur les feuilles. *)
  module Leaves : ENUM with type collection = expr = struct

    type t = expr list

    type elt = int
    type collection = expr

    let eval x = x
    let pp ch i = Format.fprintf ch "%d" i

    let init expr = [expr]

    let rec next = function
      | I i :: more -> Some (i, more)
      | Op (o,a,b) :: more -> next (a::b::more)
      | [] -> None

  end

  module T0 = Test(Leaves)

  (** Itérateur sur les sous-arbres. *)
  module Subtree : ENUM with type collection = expr = struct

    type t = expr list

    type elt = expr
    type collection = expr

    let init expr = [expr]

    let next = function
      | I i :: more -> Some (I i, more)
      | Op (o,a,b) as t :: more -> Some (t, a::b::more)
      | [] -> None

    let eval = eval
    let pp = pp_expr

  end

  module T1 = Test(Subtree)

  (** Itérateur sur les arbres plongeables, en CPS. *)
  module Embedded : ENUM with type collection = expr = struct

    type t = { k : unit -> res }
    and res = (expr*t) option

    type elt = expr
    type collection = expr

    let next it = it.k ()

    let rec embedded t f k =
      match t with
        | I _ -> f t k
        | Op (o,a,b) ->
            (* Pour chaque sous-arbre de a, on le remonte,
             * puis on le combine avec chaque sous-arbre de b.
             * Enfin on énumère les sous-arbres de b en isolation. *)
            embedded a
              (fun a' k' ->
                 f a' (fun () ->
                 embedded b
                   (fun b' k'' ->
                      f (Op (o,a',b')) k'')
                   k'))
              (fun () -> embedded b f k)

    let f0 x k : res = Some (x,{ k = k })
    let k0 = fun () -> None
    let init e = { k = fun () -> embedded e f0 k0 }

    let eval = eval
    let pp = pp_expr

  end

  module T2 = Test(Embedded)

  (** Itérateur sur les arbres plongeables, défonctionnalisé. *)
  module Embedded2 : ENUM with type collection = expr = struct

    type f = (* expr -> k1 -> res *)
      | FSome
      | FLeft of (f*expr*op)  (* f,b,o *)
      | FRight of (f*op*expr) (* f,o,a' *)

    type k = (* unit -> res *)
      | KNone
      | KLeft of (expr*f*op*expr*k) (* b,f,o,a',k' *)
      | KRight of (expr*f*k)        (* b,f,k *)
      | E of expr

    type t = k
    type res = (expr*t) option

    let rec apply_k = function
      | KNone -> None
      | KLeft (b,f,o,a',k') -> embedded b (FRight (f,o,a')) k'
      | KRight (b,f,k) -> embedded b f k
      | E e -> embedded e FSome KNone
    and apply_f f e k = match f with
      | FSome -> Some (e,k)
      | FLeft (f,b,o) ->
          let a' = e and k' = k in
            apply_f f a' (KLeft (b,f,o,a',k'))
      | FRight (f,o,a') ->
          let b' = e and k'' = k in
            apply_f f (Op (o,a',b')) k''
    and embedded t f k =
      match t with
        | I _ -> apply_f f t k
        | Op (o,a,b) -> embedded a (FLeft (f,b,o)) (KRight (b,f,k))

    type elt = expr
    type collection = expr

    let next = apply_k

    let init e = E e

    let eval = eval
    let pp = pp_expr

  end

  module T3 = Test(Embedded2)

  (** Itérateur sur les arbres plongeables,
    * défonctionnalisé et un peu simplifié. *)
  module Embedded3 : ENUM with type collection = expr = struct

    (* On remarque:
     *   KLeft (b,f,o,a',k) = KRight (b,FRight (f,o,a'),k)
     *   E t = KRight (t,FSome,KNone)
     * On a alors k composé de KNone et KRight, ce qui
     * revient à une liste de expr*f. En fait c'est une
     * todo list de tâches à faire exécuter à embedded.
     * On supprime aussi apply_k en l'inlinant dans next,
     * et on renomme apply_f en zip, nom usuel pour une
     * fonction de mise en contexte, car f décrit bien
     * un genre de contexte et zip décrit comment on
     * replace une solution pour un sous-arbre dans
     * son contexte pour obtenir la solution finale. *)

    type f =
      | FSome
      | FLeft of (f*expr*op)  (* f,b,o *)
      | FRight of (f*op*expr) (* f,o,a' *)

    type k = (expr*f) list

    let rec zip f e k = match f with
      | FSome -> Some (e,k)
      | FLeft (f,b,o) ->
          let a' = e and k' = k in
            zip f a' ((b,FRight (f,o,a'))::k')
      | FRight (f,o,a') ->
          let b' = e and k'' = k in
            zip f (Op (o,a',b')) k''
    and embedded t f k =
      match t with
        | I _ -> zip f t k
        | Op (o,a,b) -> embedded a (FLeft (f,b,o)) ((b,f)::k)

    type t = k
    type res = (expr*t) option

    type elt = expr
    type collection = expr

    let next = function
      | [] -> None
      | (b,f)::k -> embedded b f k

    let init e = [e,FSome]

    let eval = eval
    let pp = pp_expr

  end

  module T4 = Test(Embedded3)

end