Import Debian changes 20180207-1

[hcoop/debian/mlton.git] / benchmark / tests / count-graphs.sml

(* Written by Henry Cejtin (henry@sourcelight.com). *)

fun print _ = ()

(*
 * My favorite high-order procedure.
 *)
fun fold (lst, folder, state) =
        let fun loop (lst, state) =
                        case lst of
                        [] => state
                        | first::rest => loop (rest, folder (first, state))
        in loop (lst, state)
        end

fun naturalFold (limit, folder, state) =
        if limit < 0
            then raise Domain
            else let fun loop (i, state) =
                             if i = limit
                                 then state
                                 else loop (i+1, folder (i, state))
                 in loop (0, state)
                 end

fun naturalAny (limit, ok) =
        if limit < 0
            then raise Domain
            else let fun loop i =
                             i <> limit andalso
                                 (ok i orelse loop (i+1))
                 in loop 0
                 end

fun naturalAll (limit, ok) =
        if limit < 0
            then raise Domain
            else let fun loop i =
                             i = limit orelse
                                 (ok i andalso loop (i+1))
                 in loop 0
                 end
(*
 * Fold over all permutations.
 * Universe is a list of all the items to be permuted.
 * pFolder is used to build up the permutation.  It is called via
 *      pFolder (next, pState, state, accross)
 * where next is the next item in the permutation, pState is the
 * partially constructed permutation and state is the current fold
 * state over permutations that have already been considered.
 * If pFolder knows what will result from folding over all permutations
 * descending from the resulting partial permutation (starting at state),
 * it should raise the accross exception carrying the new state value.
 * If pFolder wants to continue building up the permutation, it should
 * return (newPState, newState).
 * When a permutation has been completely constructed, folder is called
 * via
 *      folder (pState, state)
 * where pState is the final pState and state is the current state.
 * It should return the new state.
 *)
fun 'a foldOverPermutations (universe, pFolder, pState, folder, state: 'a) =
        let exception accross of 'a
            fun outer (universe, pState, state) =
                    case universe of
                    [] => folder (pState, state)
                    | first::rest =>
                        let fun inner (first, rest, revOut, state) =
                                    let val state =
                                                let val (newPState, state) =
                                                            pFolder (first,
                                                                     pState,
                                                                     state,
                                                                     accross)
                                                in outer (fold (revOut,
                                                                op ::,
                                                                rest),
                                                          newPState,
                                                          state)
                                                end handle accross state => state
                                    in case rest of
                                       [] => state
                                       | second::rest =>
                                           inner (second,
                                                  rest,
                                                  first::revOut,
                                                  state)
                                    end
                        in inner (first, rest, [], state)
                        end
        in outer (universe, pState, state)
        end
(*
 * Fold over all arrangements of bag elements.
 * Universe is a list of lists of items, with equivalent items in the
 * same list.
 * pFolder is used to build up the permutation.  It is called via
 *      pFolder (next, pState, state, accross)
 * where next is the next item in the permutation, pState is the
 * partially constructed permutation and state is the current fold
 * state over permutations that have already been considered.
 * If pFolder knows what will result from folding over all permutations
 * descending from the resulting partial permutation (starting at state),
 * it should raise the accross exception carrying the new state value.
 * If pFolder wants to continue building up the permutation, it should
 * return (newPState, newState).
 * When a permutation has been completely constructed, folder is called
 * via
 *      folder (pState, state)
 * where pState is the final pState and state is the current state.
 * It should return the new state.
 *)
fun 'a foldOverBagPerms (universe, pFolder, pState, folder, state: 'a) =
        let exception accross of 'a
            fun outer (universe, pState, state) =
                    case universe of
                    [] => folder (pState, state)
                    | (fbag as (first::fclone))::rest =>
                        let fun inner (fbag, first, fclone, rest, revOut, state) =
                                    let val state =
                                                let val (newPState, state) =
                                                            pFolder (first,
                                                                     pState,
                                                                     state,
                                                                     accross)
                                                in outer (fold (revOut,
                                                                op ::,
                                                                case fclone of
                                                                [] => rest
                                                                | _ => fclone::rest),
                                                          newPState,
                                                          state)
                                                end handle accross state => state
                                    in case rest of
                                       [] => state
                                       | (sbag as (second::sclone))::rest =>
                                           inner (sbag,
                                                  second,
                                                  sclone,
                                                  rest,
                                                  fbag::revOut,
                                                  state)
                                    end
                        in inner (fbag, first, fclone, rest, [], state)
                        end
        in outer (universe, pState, state)
        end
(*
 * Fold over the tree of subsets of the elements of universe.
 * The tree structure comes from the root picking if the first element
 * is in the subset, etc.
 * eFolder is called to build up the subset given a decision on wether
 * or not a given element is in it or not.  It is called via
 *      eFolder (elem, isinc, eState, state, fini)
 * If this determines the result of folding over all the subsets consistant
 * with the choice so far, then eFolder should raise the exception
 *      fini newState
 * If we need to proceed deeper in the tree, then eFolder should return
 * the tuple
 *      (newEState, newState)
 * folder is called to buld up the final state, folding over subsets
 * (represented as the terminal eStates).  It is called via
 *      folder (eState, state)
 * It returns the new state.
 * Note, the order in which elements are folded (via eFolder) is the same
 * as the order in universe.
 *)
fun 'a foldOverSubsets (universe, eFolder, eState, folder, state: 'a) =
        let exception fini of 'a
            fun f (first, rest, eState) (isinc, state) =
                    let val (newEState, newState) =
                                eFolder (first,
                                         isinc,
                                         eState,
                                         state,
                                         fini)
                    in outer (rest, newEState, newState)
                    end handle fini state => state
            and outer (universe, eState, state) =
                        case universe of
                        [] => folder (eState, state)
                        | first::rest =>
                            let val f = f (first, rest, eState)
                            in f (false, f (true, state))
                            end
            in outer (universe, eState, state)
            end

fun f universe =
        foldOverSubsets (universe,
                         fn (elem, isinc, set, state, _) =>
                             (if isinc
                                  then elem::set
                                  else set,
                              state),
                         [],
                         fn (set, sets) => set::sets,
                         [])
(*
 * Given a partitioning of [0, size) into equivalence classes (as a list
 * of the classes, where each class is a list of integers), and where two
 * vertices are equivalent iff transposing the two is an automorphism
 * of the full subgraph on the vertices [0, size), return the equivalence
 * classes for the graph.  The graph is provided as a connection function.
 * In the result, two equivalent vertices in [0, size) remain equivalent
 * iff they are either both connected or neither is connected to size.
 * The vertex size is equivalent to a vertex x in [0, size) iff
 *      connected (size, y) = connected (x, if y = x then size else y)
 * for all y in [0, size).
 *)
fun refine (size: int,
            classes: int list list,
            connected: int*int -> bool): int list list =
        let fun sizeMatch x =
                (* Check if vertex size is equivalent to vertex x. *)
                    naturalAll (size,
                                fn y => connected (size, y) =
                                            connected (x,
                                                       if y = x
                                                           then size
                                                           else y))
            fun merge (class, (merged, classes)) =
                (* Add class into classes, testing if size should be merged. *)
                    if merged
                        then (true, (rev class)::classes)
                        else let val first::_ = class
                             in if sizeMatch first
                                    then (true, fold (class,
                                                      op ::,
                                                      [size])::classes)
                                    else (false, (rev class)::classes)
                             end
            fun split (elem, (yes, no)) =
                    if connected (elem, size)
                        then (elem::yes, no)
                        else (yes, elem::no)
            fun subdivide (class, state) =
                    case class of
                    [first] => merge (class, state)
                    | _ => case fold (class, split, ([], [])) of
                           ([], no) => merge (no, state)
                           | (yes, []) => merge (yes, state)
                           | (yes, no) => merge (no, merge (yes, state))
        in case fold (classes, subdivide, (false, [])) of
           (true, classes) => rev classes
           | (false, classes) => fold (classes, op ::, [[size]])
        end
(*
 * Given a count of the number of vertices, a partitioning of the vertices
 * into equivalence classes (where two vertices are equivalent iff
 * transposing them is a graph automorphism), and a function which, given
 * two distinct vertices, returns a bool indicating if there is an edge
 * connecting them, check if the graph is minimal.
 * If it is, return
 *      SOME how-many-clones-we-walked-through
 * If not, return NONE.
 * A graph is minimal iff its connection matrix is (weakly) smaller
 * then all its permuted friends, where true is less than false, and
 * the entries are compared lexicographically in the following order:
 *      -
 *      0 -
 *      1 2 -
 *      3 4 5 -
 *      ...
 * Note, the vertices are the integers in [0, nverts).
 *)
fun minimal (nverts: int,
             classes: int list list,
             connected: int*int -> bool): int option =
        let val perm = Array.array (nverts, ~1)
            exception fini
            fun pFolder (new, old, state, accross) =
                    let fun loop v =
                                if v = old
                                    then (Array.update (perm, old, new);
                                          (old + 1, state))
                                    else case (connected (old,
                                                          v),
                                               connected (new,
                                                          Array.sub (perm,
                                                                     v))) of
                                         (true, false) =>
                                             raise (accross state)
                                         | (false, true) =>
                                             raise fini
                                         | _ =>
                                             loop (v + 1)
                    in loop 0
                    end
            fun folder (_, state) =
                    state + 1
        in SOME (foldOverBagPerms (
                     classes,
                     pFolder,
                     0,
                     folder,
                     0)) handle fini => NONE
        end
(*
 * Fold over the tree of graphs.
 *
 * eFolder is used to fold over the choice of edges via
 *      eFolder (from, to, isinc, eState, state, accross)
 * with from > to.
 *
 * If eFolder knows the result of folding over all graphs which agree
 * with the currently made decisions, then it should raise the accross
 * exception carrying the resulting state as a value.
 *
 * To continue normally, it should return the tuple
 *      (newEState, newState)
 *
 * When all decisions are made with regards to edges from `from', folder
 * is called via
 *      folder (size, eState, state, accross)
 * where size is the number of vertices in the graph (the last from+1) and
 * eState is the final eState for edges from `from'.
 *
 * If folder knows the result of folding over all extensions of this graph,
 * it should raise accross carrying the resulting state as a value.
 *
 * If extensions of this graph should be folded over, it should return
 * the new state.
 *)
fun ('a, 'b) foldOverGraphs (eFolder, eState: 'a, folder, state: 'b) =
        let exception noextend of 'b
            fun makeVertss limit =
                    Vector.tabulate (limit,
                                     fn nverts =>
                                             List.tabulate (nverts,
                                                            fn v => v))
            val vertss = ref (makeVertss 0)
            fun findVerts size = (
                    if size >= Vector.length (!vertss)
                        then vertss := makeVertss (size + 1)
                        else ();
                    Vector.sub (!vertss, size))
            fun f (size, eState, state) =
                    let val state =
                                folder (size, eState, state, noextend)
                    in g (size+1, state)
                    end handle noextend state => state
            and g (size, state) =
                    let val indices =
                                findVerts (size - 1)
                        fun SeFolder (to, isinc, eState, state, accross) =
                                eFolder (size-1,
                                         to,
                                         isinc,
                                         eState,
                                         state,
                                         accross)
                        fun Sf (eState, state) =
                                f (size, eState, state)
                    in foldOverSubsets (
                        indices,
                        SeFolder,
                        eState,
                        Sf,
                        state)
                    end
        in f (0, eState, state)
        end

(*
 * Given the size of a graph, a list of the vertices (the integers in
 * [0, size)), and the connected function, check if for all full subgraphs,
 *      3*V - 4 - 2*E >= 0 or V <= 1
 * where V is the number of vertices and E is the number of edges.
 *)
local fun short lst =
        case lst of
        [] => true
        | [_] => true
        | _ => false
in fun okSoFar (size, verts, connected) =
        let exception fini of unit
            fun eFolder (elem, isinc, eState as (ac, picked), _, accross) =
                    (if isinc
                         then (fold (picked,
                                     fn (p, ac) =>
                                         if connected (elem, p)
                                             then ac - 2
                                             else ac,
                                     ac + 3),
                               elem::picked)
                         else eState,
                     ())
            fun folder ((ac, picked), state) =
                    if ac >= 0 orelse short picked
                        then state
                        else raise (fini ())
        in (foldOverSubsets (
               verts,
               eFolder,
               (~4, []),
               folder,
               ());
            true) handle fini () => false
        end
end

fun showGraph (size, connected) =
        naturalFold (size,
                     fn (from, _) => (
                         print ((Int.toString from) ^ ":");
                         naturalFold (size,
                                      fn (to, _) =>
                                          if from <> to andalso connected (from, to)
                                              then print (" " ^ (Int.toString to))
                                              else (),
                                      ());
                         print "\n"),
                     ());

fun showList (start, sep, stop, trans) lst = (
        start ();
        case lst of
        [] => ()
        | first::rest => (
            trans first;
            fold (rest,
                  fn (item, _) => (
                      sep ();
                      trans item),
                  ()));
        stop ())

val showIntList = showList (
                      fn () => print "[",
                      fn () => print ", ",
                      fn () => print "]",
                      fn i => print (Int.toString i))

val showIntListList = showList (
                      fn () => print "[",
                      fn () => print ", ",
                      fn () => print "]",
                      showIntList)

fun h (maxSize, folder, state) =
        let val ctab = Array.tabulate (maxSize,
                                       fn v => Array.array (v, false))
            val classesv = Array.array (maxSize+1, [])
            fun connected (from, to) =
                let val (from, to) = if from > to
                                         then (from, to)
                                         else (to, from)
                in Array.sub (Array.sub (ctab, from), to)
                end
            fun update (from, to, value) =
                let val (from, to) = if from > to
                                         then (from, to)
                                         else (to, from)
                in Array.update (Array.sub (ctab, from), to, value)
                end
            fun triangle (vnum, e) =
                naturalAny (e,
                            fn f => connected (vnum, f)
                                        andalso connected (e, f))
            fun eFolder (from, to, isinc, _, state, accross) =
                    if isinc andalso triangle (from, to)
                        then raise (accross state)
                        else (
                            update (from, to, isinc);
                            ((), state))
            fun Gfolder (size, _, state, accross) = (
                    if size <> 0
                        then Array.update (classesv,
                                           size,
                                           refine (size-1,
                                                   Array.sub (classesv,
                                                              size-1),
                                           connected))
                        else ();
                    case minimal (size, Array.sub (classesv, size), connected) of
                    NONE => raise (accross state)
                    | SOME eatMe =>
                        if okSoFar (size,
                                    List.tabulate (size, fn v => v),
                                    connected)
                            then let val state =
                                         folder (size, connected, state)
                                 in if size = maxSize
                                        then raise (accross state)
                                        else state
                                 end
                            else raise (accross state))
        in foldOverGraphs (eFolder,
                           (),
                           Gfolder,
                           state)
        end

local fun final (size: int, connected: int * int -> bool): int =
        naturalFold (size,
                     fn (from, ac) =>
                         naturalFold (from,
                                      fn (to, ac) =>
                                          if connected (from, to)
                                              then ac - 2
                                              else ac,
                                      ac),
                     3*size - 4)
in fun f maxSize =
        h (maxSize,
           fn (size, connected, state) =>
                   if final (size, connected) = 0
                       then state + 1
                       else state,
           0)
end

fun doOne arg = (
        print (arg ^ " -> ");
        case Int.fromString arg of
        SOME n =>
                print ((Int.toString (f n)) ^ "\n")
        | NONE =>
                print "NOT A NUMBER\n")

   structure Main =
      struct
         fun doit() =
            List.app doOne ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11"]

         val doit =
            fn size =>
            let
               fun loop n =
                  if n = 0
                     then ()
                  else (doit();
                        loop(n-1))
            in loop size
            end
      end