(* as in https://en.wikipedia.org/wiki/Standard_ML
 * it is "destinctive" among widely used languages
   in that it has a "formal" specification, given as
   typing rules and operational semantics.
 * Though, to be honest: if one can't read,
   nothing except the fact-itself is formal proof.
 * Dare call me dumb, for that'd be right.

 * See also C++ and LCF (Logic for Computable Functions),
 * the reason for this embark on M(eta)L(anguage).
 *)
fun factorial n =
  if n = 0 then 1 else n * factorial (n - 1)

fun factorial 0 = 1
  | factorial n = n * factorial (n - 1)

fun factorial n = let val i = ref n and acc = ref 1 in
  while !i > 0 do (acc := !acc * !i; i := !i - 1); !acc
end

val rec factorial = fn 0 => 1 | n => n * factorial (n - 1)

(* "Local definitions"
 * encapsulation of an
   "invariant-preserving tail-recursive tight-loop"
   with one or more accumulator parameters within
   an "invariant-free outer function", "as seen here".
 *)
local
  fun loop (0,acc) = acc
    | loop (m,acc) = loop (m - 1,m * acc)
in
  fun factorial n = loop (n,1)
end

(* "Type synonyms"
 * Here is usage of a "type" synonym for points on a plane.
   ("http://smlhelp.github.io/book/docs/start/syntax")
 * Base "type" synonyms are:
  Type     Sample
  -x-x-    -x-x-
   int      0
   string   "tarte"
   char     #" "
   bool     true
   real     1.0
   unit     ()
 * Base operations on those include:
 * Structured "type" samples:
  Type
   Sample
  -x-x-x-
   int * int
    (15,150)
   int list
    [1,2,3]
   string list list
    [["gandalf","the grey"],["wrote many post-scripts"]]
   (bool * int) * (bool * int * unit)
    ((true,1),(false,0,()))
   (int * int) list
    [(0,1),(1,0)]
   char list * real list
    ([#"a",#"b"],[3.14])
 *)
type loc = real * real
fun square (x : real) = x * x
fun dist (x,y) (x',y') =
  Math.sqrt (square (x' - x) + square (y' - y))
fun heron (a,b,c) = let
  val x = dist a b
  val y = dist b c
  val z = dist a c
  val s = (x + y + z)/ 2.0
  in
    Math.sqrt (s * (s - x) * (s - y) * (s - z))
  end

(* "Algebraic datatypes"
 * ADTs are "disjoint unions of tuples" (or a "sum of products")
   They are "easily defined" and "easy to use", largely
   because of "pattern matching"
     (our ability to see a banana)
   and most S-MLs "pattern-exhaustiveness" checks
     ()
   and "pattern-redundancy" checks.
 * A "type" synonym may not be recursive,
   datatypes are for defining "constructors" -recursive or not.
 *)
datatype shape
  = Circle of loc * real (*centere and radius*)
  | Square of loc * real (*upper-left corner and side length*)
  | Triangle of loc * loc * loc (*corners*)
(* the datatype (option) handles potential undefined values.
   ("http://smlhelp.github.io/book/docs/types/options")
 *)
datatype 'a option = NONE | SOME of 'a
Option.getOpt : 'a option * 'a -> 'a
Option.getOpt (x option,y)
(* evaluates into one of the below *)
Option.getOpt (SOME x,y) (* gets x *)
Option.getOpt (NONE,y) (* gets y *)
(*
 * take the following example
 *)
fun defaultThree (NONE : int option):int = 3
  | defaultThree (SOME x) = x
val 2 = defaultThree(SOME 2)
val 3 = defaultThree(NONE)
fun searchEvens [] = NONE
  | searchEvens (x::xs) = if (x mod 2) = 0 then SOME x else searchEvens xs
val (SOME _) = searchEvens [1,2]
val NONE = searchEvens [1,3]

(* "Pattern matching"
 * Patterns are matched in the order in which they are defined.
 * C programmers use "tagged unions", dispatching on tag values,
   to do what ML does with datatypes and pattern matching.
 * However; unions provide run-time checks,
   whereas MLs check at compile-time.
 *)
fun area (Circle (_,r)) = Math.pi * square r
  | area (Square (_,s)) = square s
  | area (Triangle p) = heron p (*see above*)
(* this, the "clausal form", is only syntactic sugar
   for the equivalent case expression:
 *)
fun area shape = case shape of
    Circle (_,r) => Math.pi * square r
  | Square (_,s) => square s
  | Triangle p => heron p

(* "Pattern-exhaustiveness" checks
   whether some constructors of shared
   datatype are not included in a case expression.
   If so, they cause Dr. Compiler to issue warnings.
 *)
fun center (Circle (c,_)) = c
  | center (Square ((x,y),s)) = (x + s / 2.0,y + s / 2.0)
(* Pattern (Triangle) of datatype (shape) is not defined.
   The standard is to raise (exception Match) if (Triangle)
   in this case was to be passed to the function (center)
   at runtime.
 *)

(* "Pattern-redundancy" checks
   whether more patterns share all their cases.
   If so, they cause Dr. Compiler to issue warnings.
 *)
fun f _ = 1.0
  | f 0 = 0.0 (*unreachable*)

(* The following passes the "redundancy" and "exhaustiveness" checks,
 * because past (Circle) a typeless case resulting in (true) appears.
 *)
val cornered? = fn (Circle _) => false | _ => true

(* "Higher-order functions"
 * blabla yadayadayee.
 *)
fun map f (x,y) = (f x,f y)
fun constant k = (fn _ => k)
fun compose (f,g) = (fn x => f (g x))
fun map _ [] = []
  | map f (x :: xs) = f x :: map f xs
(* or with the tail-recurse (List.foldl) *)
fun map f = List.rev o List.foldl (fn (x,acc) => f x :: acc) []

(* "Exceptions"
 * Exceptions arise with the keyword (raise) and recede
   back into depth with the pattern matching (handle).
 * The exception system implements non-local exits; this
   optimization technique is suitable [...]:
 *)
local
  exception Zero;
  val p = fn (0,_) => raise Zero | (a,b) => a * b
in
  fun prod xs = List.foldl p 1 xs handle Zero => 0
end
(* the following tail-call does the same. *)
local
  fun p a (0 :: _) = 0
    | p a (x :: xs) = p (a * x) xs
    | p a [] = a
in
  val prod = p 1
end

(* "Module system"
 * (signature) provides interface specification of a module,
   like a header file in the C world describes a source file.
 * (structure) is the module, or source; providing the logical
   facilities for the praised functionality in the (signature).
 *)
signature QUEUE = sig
  type 'a queue
  exception QueueError;
  val empty : 'a queue
  val empty? : 'a queue -> bool
  val singletion : 'a -> 'a queue
  val fromList : 'a list -> 'a queue
  val insert : 'a * 'a queue -> 'a queue
  val peek : 'a queue -> 'a
  val remove : 'a queue -> 'a * 'a queue
end
structure TwoListQueue :> QUEUE = struct
  type 'a queue = 'a list * 'a list
  exception QueueError;

  val empty = ([],[])
  fun empty? ([],[]) = true
    | empty? _ = false
  fun singleton a = ([],[a])
  fun fromList a = ([],a)
  fun insert (a,([],[])) = singleton a
    | insert (a,(ins,outs)) = (a :: ins,outs)
  fun peek (_,[]) = raise QueueError
    | peek (ins,outs) = List.hd outs
  fun remove (_,[]) = raise QueueError
    | remove (ins,[a]) = (a,([],List.rev ins))
    | remove (ins,a :: outs) =  (a,(ins,outs))
end
(* types and values of a structure are then requested like so *)
val q : string TwoListQueue.queue = TwoListQueue.empty
val q' = TwoListQueue.insert (Real.toString Math.pi,q)
(* a functor is a function from structures to structures *)
(* after Okasaki, ICFP,2000 *)
functor BFS (Q: QUEUE) = struct
  datatype 'a tree = E | T of 'a * 'a tree * 'a tree

  local
    fun bfsQ q = if Q.empty? q then [] else search(Q.remove q)
    and search (E,q) = bfsQ q
      | search (T (x,l,r),q) = x :: bfsQ (insert (insert q l) r)
    and insert q a = Q.insert (a,q)
  in
    fun bfs t = bfsQ (Q.singleton t)
  end
end
structure QueueBFS = BFS (TwoListQueue)

print "Hello, world!\n";