StandardML.fold

-- Like all functional programming languages, a key feature of Fold is the
-- function, which is used for abstraction. For instance, the factorial
-- function can be expressed as:
fun factorial n =
  if n == 0 then 1
  else n * factorial (n - 1)


-- The same function can be expressed with clausal function definitions where
-- the if-then-else conditional is replaced by a sequence of templates of the
-- factorial function evaluated for specific values, separated by '|', which
-- are tried one by one in the order written until a match is found:
fun factorial 0 = 1
  | factorial n = n * factorial (n - 1)


-- This can be rewritten using a case statement like this:
fun factorial =
  n -> match n
       | 0 -> 1,
       | n -> n * factorial (n - 1)
       end


-- or as a lambda function:
val factorial = 0 -> 1 | n -> n * factorial (n - 1)


-- Using a local function, this function can be rewritten in a more efficient
-- tail recursive style.
fun factorial n =
  let loop (0, acc) = acc
    | loop (n, acc) = loop (n - 1, n * acc) in
  loop (n, 1)


-- Product type defining a 2D coordinate.
type Loc = (Float, Float)


fun dist (x0, y0) (x1, y1) =
  let dx = x1 - x0,
      dy = y1 - y0 in
  Math.sqrt (dx * dx + dy * dy)


fun heron (a, b, c) =
  let ab = dist a b,
      bc = dist b c,
      ac = dist a c,
      perim = ab + bc + ac,
      s = perim / 2.0 in
  Math.sqrt (s * (s - ab) * (s - bc) * (s - ac))


-- A data type is defined with the datatype keyword, as in:
type Shape =
  | Circle   (Loc, Float)      -- center and radius
  | Square   (Loc, Float)      -- upper-left corner and side length; axis-aligned
  | Triangle (Loc, Loc, Loc)   -- corners


-- Order matters in pattern matching; patterns that are textually first are
-- tried first. Pattern matching can be syntactically embedded in function
-- definitions as follows:
fun area (Circle (_, r)) = 3.14 * r * r
  | area (Square (_, s)) = s * s
  | area (Triangle (a, b, c)) = heron (a, b, c) -- see above


-- The so-called "clausal form" style function definition, where patterns
-- appear immediately after the function name, is merely syntactic sugar for
fun area shape =
  case shape
  | Circle (_, r) -> 3.14 * r * r,
  | Square (_, s) -> s * s,
  | Triangle (a, b, c) -> heron (a, b, c)
  end


-- Pattern exhaustiveness checking will make sure each case of the datatype has
-- been accounted for, and will produce a warning if not. The following pattern is
-- inexhaustive:
fun center (Circle (c, _)) = c
  | center (Square ((x, y), s)) = (x + s / 2.0, y + s / 2.0)


-- The set of clauses in the following function definition is exhaustive and
-- not redundant:
fun has_corners (Circle _) = False
  | has_corners _ = True

-- The pattern in the second clause of the following (meaningless) function is
-- redundant:
fun f (Circle ((x, y), r)) = x + y
  | f (Circle _) = 1.0
  | f _ = 0.0

-- Functions can produce functions as return values:
fun const k = _ -> k

-- Functions can also both consume and produce functions:
fun compose f g = x -> f (g x)

-- Infix version
fun (f << g) = x -> f (g x)

-- The function List.map from the basis library is one of the most commonly
-- used higher-order functions in Fold:
fun map _ [] = []
  | map f [x & xs] = [f x & map f xs]

-- A more efficient implementation of map would define a tail-recursive inner loop as follows:
fun map f xs =
  let loop ([], acc) = List.rev acc
    | loop ([x & xs], acc) = loop (xs, [f x & acc]) in
  loop (xs, [])

-- Exceptions are raised with the raise keyword, and handled with pattern
-- matching try constructs.
exception Undefined

fun max [x] = x
  | max [x & xs] = let m = max xs in if x > m then x else m
  | max [] = raise Undefined


val () =
  try string (max xs) with
  | Undefined -> "empty list...there is no max!"
  end
  |> print


-- The exception system can be exploited to implement non-local exit, an
-- optimization technique suitable for functions like the following.

exception Zero

fun product ns =
  let loop [] = 1
    | loop [0 & _] = raise Zero
    | loop [h & t] = h * product t
  in
    try p ns with Zero -> 0 end


-- The interface for a queue data structure might be:
interface Queue
    type Self a
    exception QueueError

    val empty     :: Self a
    val is_empty  :: Self a -> Bool
    val singleton :: a -> Self a
    val insert    :: a -> Self a -> Self a
    val peek      :: Self a -> a
    val remove    :: Self a -> (a, Self a)
end


-- One can now implement the queue data structure by writing a structure with
-- this signature:
module TwoListQueue :: Queue
   type Self a = (List a, List a)

   exception QueueError

   val empty = ([], [])

   fun is_empty ([], []) = True
     | is_empty _ = False

   fun singleton a = ([], [a])

   fun insert a ([], []) = ([], [a])
     | insert a (ins, outs) = (a & ins, outs)

   fun peek (_, []) = raise QueueError
     | peek (ins, a & outs) = a

   fun remove (_, []) = raise QueueError
     | remove (ins, [a]) = (a, ([], rev ins))
     | remove (ins, a & outs) = (a, (ins, outs))
end


-- after Okasaki, ICFP, 2001
module BFS (Q :: Queue)
  type Tree a = E | T (a, Tree a, Tree a)

  fun bfs_q (q :: Q Tree a) -> List a =
    if Q.is_empty q
    then []
    else
      let (t, q') = Q.remove q in
      case t
      | E -> bfs_q q'
      | T (x, l, r) ->
        let q'' = Q.insert (r, Q.insert (l, q')) in
        [x & bfs_q q'']
      end

  fun bfs t =
    bfs_q (Q.singleton t)
end


-- Euclidian distance
fun euclid (m, n) :: (Int, Int) -> Int =
  if n == 0
  then (b 1, b 0, m)
  else
    let (q, r) = (m / n, m % n),
        (u, v, g) = euclid (n, r)
    in
      (v, u - q * v, g)