(* Dynamic OCaml: OCaml as Scheme *)
(* This is a simple illustration of Robert Harper's thesis that a statically
   typed language embeds a dynamically typed one.
   We show how to express in OCaml characteristic Scheme features:
    intentionally polymorphic functions; polymorphic lists;
    functions with a variable number of polymorphic arguments;
    fix-point and self-application (\x.x x) combinators not 
    normally expressible in ML; higher-order polymorphic polyvariadic
    functions (e.g., iterator over multiple lists in parallel)
  The code takes the fullest advantage of latent typing, with
  no type annotations whatsoever.

  All the code below is trivial -- and that is the point. Defining and
  using the Universal type in a statically typed language is indeed
  embarrassingly easy.

  Please see scheme-ml.txt in this directory for more discussion.
*)


(* The key to the dynamic typing is the Universal type *)
(* We limit ourselves to a pure-functional subset of Scheme. References
   and first-class continuations can be easily supported too.
   `Scheme' procedures are expressed in a higher-order syntax. 
   As in real Scheme, the embedded Scheme procedures take a list of arguments.
*)

type scm = False | True | Void
	   | Char of char
	   | Str of string
	   | Int of int
	   | Flo of float
	   | List of scm list
	   | Vec of scm array
	   | Proc of (scm list -> scm)

let s_apply (Proc f) args = f args;;    (* procedure application *)

(* We start by defining a few standard Scheme procedures *)

(* intentionally polymorphic subtraction *)
(* The pattern-match below is deliberately non-exhaustive; applying
   the s_sub procedure to the wrong number of arguments or to arguments
   of wrong types should raise a run-time exception -- just as it does
   in Scheme.
*)
let s_sub [x;y] = match (x,y) with
	(Int xn, Int yn) -> Int (xn - yn)
      | (Flo xn, Flo yn) -> Flo (xn -. yn)
      | (Flo xn, Int yn) -> Flo (xn -. float yn)
      | (Int xn, Flo yn) -> Flo (float xn -. yn)
;;

(* polymorphic multiplication *)
let s_mul2 [x;y] = match (x,y) with
	(Int xn, Int yn) -> Int (xn * yn)
      | (Flo xn, Flo yn) -> Flo (xn *. yn)
      | (Flo xn, Int yn) -> Flo (xn *. float yn)
      | (Int xn, Flo yn) -> Flo (float xn *. yn)
;;

(* polymorphic multiplication of an arbitrary number of arguments *)
let s_mul (x::rest) = List.fold_left (fun acc e -> s_mul2 [acc;e]) x rest 
;;

(* intentionally polymorphic `display' function *)
let rec display = function
	[True]   -> print_string "#t"; Void
      | [False]  -> print_string "#f"; Void
      | [Void]   -> Void
      | [Char c] -> print_char c; Void 
      | [Int n]  -> print_int n; Void
      | [Flo n]  -> print_float n; Void
      | [Str str] -> print_string str; Void
      | [List lst] -> let rec print_lst = function
				[] -> Void
			      | [el] -> display [el]
			      | el::rest -> display [el]; print_string " ";
			                    print_lst rest
			   in
		             print_string "("; print_lst lst; 
			     print_string ")"; Void
      | [Proc _] -> print_string "#<procedure>"; Void
  ;;

(* This was the regular OCaml code, with no type annotations. They
   are redundant: almost everything is of the type scm anyway. We get 
   error detection and reporting with no extra coding, since pattern-match
   failures are reported automatically.
*)


(* The example of using polymorphic, nested lists *)

display [Str "\nTesting polymorphic lists and polymorphic display\n"];;
display [List [Int 1; True; False; List []; 
	 s_mul [Int 2; Flo 4.2]; Proc display; 
	 List [Int 1; Int 2; False]]];;

(* The output:

    (1 #t #f () 8.4 #<procedure> (1 2 #f))
*)

(* Granted, the notation like List [Int 1; Int 2] isn't pretty, comparing
   to Scheme's '(1 2). OTH, we can consider "List" to mean Scheme's
   "quote". Square brackets here seem to play the role of the round ones 
   in Scheme.
*)


display [Str "\nTesting multiplication of the variable number of args\n"];;
(display [s_mul [Int 1; Int 2; Int 3; Flo 4.0]]);;
(* printed result: 24. *)


(* Self-application and fixpoint *)
(* We attempt to embed the following Scheme code

	(define (u f) (f f))	; The U fixpoint combinator
	(define (fact1 self)
	  (lambda (n) (if (zero? n) 1 ( * n ((self self) (- n 1))))))
	((u fact1) 5) ==> 120

  The U combinator as it is cannot be expressed in ML directly. The naive
  expression "let u f = f f" is untypeable without resorting to
  equi-recursive types, which are normally not permitted. And yet we can
  easily write the self-application `in Scheme'... Neither u_fixpt nor
  fact1 are recursive. 
*)

let u_fixpt [f] = s_apply f [f];;

(*
 (define (fact1 self)
   (lambda (n) (if (zero? n) 1 ( * n ((self self) (- n 1))))))

 The OCaml code below looks quite like the Scheme code above, modulo
 the shape of the parentheses.
*)
let fact1 [self] = Proc(function 
	[Int 0] -> Int 1
      | [x] -> (s_mul [x; 
	                 (s_apply (s_apply self [self]) [s_sub [x; Int 1]])])
		     );;

display [Str "\nComputing a factorial via a fixpoint combinator"];;
display [Str "\nFact 1: "];;
display [ s_apply (u_fixpt [Proc fact1]) [Int 1] ] ;;

display [Str "\nFact 5: "];;
display [s_apply (u_fixpt [Proc fact1]) [Int 5] ];;


(* Parallel loop -- simultaneous iteration over the arbitrary number of lists
   -- as an example of a higher-order function with a
   variable number of variably (intentionally) typed arguments.
   We could have used List.iter. The following code is written, however,
   to match the implementation of for-each from a real Scheme system
   (Gambit-C 3.0).
*)
let rec for_each ((Proc f)::args) =
  let rec cars = function
    [List (el::_)] -> [el]
  | (List (el::_))::rest -> el::(cars rest)
  and cdrs = function
    [List (_::rest)] -> [List rest]
  | (List (_::rest1))::rest -> (List rest1)::cdrs rest
 in
  match args with
    (List [])::_ -> Void
  | x ->  f (cars x); for_each ((Proc f)::(cdrs x))
;;


let s_list x = List x;;		(* Scheme 'list' function *)

display [Str "\ntesting for-each"];

display [Str "\nDisplaying one list: "];
for_each [Proc display; List [Int 1; Int 2; Int 3]];

display [Str "\nDisplaying one list of singletons: "];
for_each [Proc (fun x -> display [s_list x]); 
          List [Int 1; Int 2; Int 3]];

display [Str "\nDisplaying two lists in parallel: "];;
(* in Scheme: (for-each (lambda x (display x))
			   '(1 2 3) '("one" "two" "three"))
*)
for_each [Proc (fun x -> display [s_list x]); 
          List [Int 1; Int 2; Int 3];
          List [Str "one"; Str "two"; Str "three"]
         ];;

(* The output is:

   (1 one)(2 two)(3 three)
*)