(* 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