1 (* Written by Henry
Cejtin (henry@sourcelight
.com
). *)
6 * My favorite high
-order procedure
.
8 fun fold (lst
, folder
, state
) =
9 let fun loop (lst
, state
) =
12 | first
::rest
=> loop (rest
, folder (first
, state
))
16 fun naturalFold (limit
, folder
, state
) =
19 else let fun loop (i
, state
) =
22 else loop (i
+1, folder (i
, state
))
26 fun naturalAny (limit
, ok
) =
31 (ok i
orelse loop (i
+1))
35 fun naturalAll (limit
, ok
) =
40 (ok i
andalso loop (i
+1))
44 * Fold over all permutations
.
45 * Universe is a list
of all the items to be permuted
.
46 * pFolder is used to build up the permutation
. It is called via
47 * pFolder (next
, pState
, state
, accross
)
48 * where next is the next item
in the permutation
, pState is the
49 * partially constructed permutation
and state is the current fold
50 * state over permutations that have already been considered
.
51 * If pFolder knows what will result from folding over all permutations
52 * descending from the resulting partial
permutation (starting at state
),
53 * it should
raise the accross
exception carrying the new state value
.
54 * If pFolder wants to continue building up the permutation
, it should
55 * return (newPState
, newState
).
56 * When a permutation has been completely constructed
, folder is called
58 * folder (pState
, state
)
59 * where pState is the final pState
and state is the current state
.
60 * It should return the new state
.
62 fun 'a
foldOverPermutations (universe
, pFolder
, pState
, folder
, state
: 'a
) =
63 let exception accross
of 'a
64 fun outer (universe
, pState
, state
) =
66 [] => folder (pState
, state
)
68 let fun inner (first
, rest
, revOut
, state
) =
70 let val (newPState
, state
) =
75 in outer (fold (revOut
,
80 end handle accross state
=> state
89 in inner (first
, rest
, [], state
)
91 in outer (universe
, pState
, state
)
94 * Fold over all arrangements
of bag elements
.
95 * Universe is a list
of lists
of items
, with equivalent items
in the
97 * pFolder is used to build up the permutation
. It is called via
98 * pFolder (next
, pState
, state
, accross
)
99 * where next is the next item
in the permutation
, pState is the
100 * partially constructed permutation
and state is the current fold
101 * state over permutations that have already been considered
.
102 * If pFolder knows what will result from folding over all permutations
103 * descending from the resulting partial
permutation (starting at state
),
104 * it should
raise the accross
exception carrying the new state value
.
105 * If pFolder wants to continue building up the permutation
, it should
106 * return (newPState
, newState
).
107 * When a permutation has been completely constructed
, folder is called
109 * folder (pState
, state
)
110 * where pState is the final pState
and state is the current state
.
111 * It should return the new state
.
113 fun 'a
foldOverBagPerms (universe
, pFolder
, pState
, folder
, state
: 'a
) =
114 let exception accross
of 'a
115 fun outer (universe
, pState
, state
) =
117 [] => folder (pState
, state
)
118 |
(fbag
as (first
::fclone
))::rest
=>
119 let fun inner (fbag
, first
, fclone
, rest
, revOut
, state
) =
121 let val (newPState
, state
) =
126 in outer (fold (revOut
,
130 | _
=> fclone
::rest
),
133 end handle accross state
=> state
136 |
(sbag
as (second
::sclone
))::rest
=>
144 in inner (fbag
, first
, fclone
, rest
, [], state
)
146 in outer (universe
, pState
, state
)
149 * Fold over the tree
of subsets
of the elements
of universe
.
150 * The tree
structure comes from the root picking
if the first element
151 * is
in the subset
, etc
.
152 * eFolder is called to build up the subset given a decision on wether
153 * or not a given element is
in it or not
. It is called via
154 * eFolder (elem
, isinc
, eState
, state
, fini
)
155 * If this determines the result
of folding over all the subsets consistant
156 * with the choice so far
, then eFolder should
raise the
exception
158 * If we need to proceed deeper
in the tree
, then eFolder should return
160 * (newEState
, newState
)
161 * folder is called to buld up the final state
, folding over subsets
162 * (represented
as the terminal eStates
). It is called via
163 * folder (eState
, state
)
164 * It returns the new state
.
165 * Note
, the order
in which elements are
folded (via eFolder
) is the same
166 * as the order
in universe
.
168 fun 'a
foldOverSubsets (universe
, eFolder
, eState
, folder
, state
: 'a
) =
169 let exception fini
of 'a
170 fun f (first
, rest
, eState
) (isinc
, state
) =
171 let val (newEState
, newState
) =
177 in outer (rest
, newEState
, newState
)
178 end handle fini state
=> state
179 and outer (universe
, eState
, state
) =
181 [] => folder (eState
, state
)
183 let val f
= f (first
, rest
, eState
)
184 in f (false, f (true, state
))
186 in outer (universe
, eState
, state
)
190 foldOverSubsets (universe
,
191 fn (elem
, isinc
, set
, state
, _
) =>
197 fn (set
, sets
) => set
::sets
,
200 * Given a partitioning
of [0, size
) into equivalence
classes (as a list
201 * of the classes
, where each class is a list
of integers
), and where two
202 * vertices are equivalent iff transposing the two is an automorphism
203 * of the full subgraph on the vertices
[0, size
), return the equivalence
204 * classes for the graph
. The graph is provided
as a connection function
.
205 * In the result
, two equivalent vertices
in [0, size
) remain equivalent
206 * iff they are either both connected or neither is connected to size
.
207 * The vertex size is equivalent to a vertex x
in [0, size
) iff
208 * connected (size
, y
) = connected (x
, if y
= x
then size
else y
)
209 * for all y
in [0, size
).
211 fun refine (size
: int,
212 classes
: int list list
,
213 connected
: int*int -> bool): int list list
=
214 let fun sizeMatch x
=
215 (* Check
if vertex size is equivalent to vertex x
. *)
217 fn y
=> connected (size
, y
) =
222 fun merge (class
, (merged
, classes
)) =
223 (* Add class into classes
, testing
if size should be merged
. *)
225 then (true, (rev class
)::classes
)
226 else let val first
::_
= class
227 in if sizeMatch first
228 then (true, fold (class
,
231 else (false, (rev class
)::classes
)
233 fun split (elem
, (yes
, no
)) =
234 if connected (elem
, size
)
237 fun subdivide (class
, state
) =
239 [first
] => merge (class
, state
)
240 | _
=> case fold (class
, split
, ([], [])) of
241 ([], no
) => merge (no
, state
)
242 |
(yes
, []) => merge (yes
, state
)
243 |
(yes
, no
) => merge (no
, merge (yes
, state
))
244 in case fold (classes
, subdivide
, (false, [])) of
245 (true, classes
) => rev classes
246 |
(false, classes
) => fold (classes
, op ::, [[size
]])
249 * Given a count
of the number
of vertices
, a partitioning
of the vertices
250 * into equivalence
classes (where two vertices are equivalent iff
251 * transposing them is a graph automorphism
), and a function which
, given
252 * two distinct vertices
, returns a
bool indicating
if there is an edge
253 * connecting them
, check
if the graph is minimal
.
255 * SOME how
-many
-clones
-we
-walked
-through
256 * If not
, return NONE
.
257 * A graph is minimal iff its connection matrix
is (weakly
) smaller
258 * then all its permuted friends
, where true is less than
false, and
259 * the entries are compared lexicographically
in the following order
:
265 * Note
, the vertices are the integers
in [0, nverts
).
267 fun minimal (nverts
: int,
268 classes
: int list list
,
269 connected
: int*int -> bool): int option
=
270 let val perm
= Array
.array (nverts
, ~
1)
272 fun pFolder (new
, old
, state
, accross
) =
275 then (Array
.update (perm
, old
, new
);
277 else case (connected (old
,
283 raise (accross state
)
290 fun folder (_
, state
) =
292 in SOME (foldOverBagPerms (
297 0)) handle fini
=> NONE
300 * Fold over the tree
of graphs
.
302 * eFolder is used to fold over the choice
of edges via
303 * eFolder (from
, to
, isinc
, eState
, state
, accross
)
306 * If eFolder knows the result
of folding over all graphs which agree
307 * with the currently made decisions
, then it should
raise the accross
308 * exception carrying the resulting state
as a value
.
310 * To continue normally
, it should return the tuple
311 * (newEState
, newState
)
313 * When all decisions are made
with regards to edges from `from
', folder
315 * folder (size
, eState
, state
, accross
)
316 * where size is the number
of vertices
in the
graph (the last from
+1) and
317 * eState is the final eState for edges from `from
'.
319 * If folder knows the result
of folding over all extensions
of this graph
,
320 * it should
raise accross carrying the resulting state
as a value
.
322 * If extensions
of this graph should be folded over
, it should return
325 fun ('a
, 'b
) foldOverGraphs (eFolder
, eState
: 'a
, folder
, state
: 'b
) =
326 let exception noextend
of 'b
327 fun makeVertss limit
=
328 Vector.tabulate (limit
,
330 List.tabulate (nverts
,
332 val vertss
= ref (makeVertss
0)
333 fun findVerts size
= (
334 if size
>= Vector.length (!vertss
)
335 then vertss
:= makeVertss (size
+ 1)
337 Vector.sub (!vertss
, size
))
338 fun f (size
, eState
, state
) =
340 folder (size
, eState
, state
, noextend
)
342 end handle noextend state
=> state
343 and g (size
, state
) =
346 fun SeFolder (to
, isinc
, eState
, state
, accross
) =
353 fun Sf (eState
, state
) =
354 f (size
, eState
, state
)
362 in f (0, eState
, state
)
366 * Given the size
of a graph
, a list
of the
vertices (the integers
in
367 * [0, size
)), and the connected function
, check
if for all full subgraphs
,
368 * 3*V
- 4 - 2*E
>= 0 or V
<= 1
369 * where V is the number
of vertices
and E is the number
of edges
.
371 local fun short lst
=
376 in fun okSoFar (size
, verts
, connected
) =
377 let exception fini
of unit
378 fun eFolder (elem
, isinc
, eState
as (ac
, picked
), _
, accross
) =
382 if connected (elem
, p
)
389 fun folder ((ac
, picked
), state
) =
390 if ac
>= 0 orelse short picked
393 in (foldOverSubsets (
399 true) handle fini () => false
403 fun showGraph (size
, connected
) =
406 print ((Int.toString from
) ^
":");
409 if from
<> to
andalso connected (from
, to
)
410 then print (" " ^
(Int.toString to
))
416 fun showList (start
, sep
, stop
, trans
) lst
= (
429 val showIntList
= showList (
433 fn i
=> print (Int.toString i
))
435 val showIntListList
= showList (
441 fun h (maxSize
, folder
, state
) =
442 let val ctab
= Array
.tabulate (maxSize
,
443 fn v
=> Array
.array (v
, false))
444 val classesv
= Array
.array (maxSize
+1, [])
445 fun connected (from
, to
) =
446 let val (from
, to
) = if from
> to
449 in Array
.sub (Array
.sub (ctab
, from
), to
)
451 fun update (from
, to
, value
) =
452 let val (from
, to
) = if from
> to
455 in Array
.update (Array
.sub (ctab
, from
), to
, value
)
457 fun triangle (vnum
, e
) =
459 fn f
=> connected (vnum
, f
)
460 andalso connected (e
, f
))
461 fun eFolder (from
, to
, isinc
, _
, state
, accross
) =
462 if isinc
andalso triangle (from
, to
)
463 then raise (accross state
)
465 update (from
, to
, isinc
);
467 fun Gfolder (size
, _
, state
, accross
) = (
469 then Array
.update (classesv
,
476 case minimal (size
, Array
.sub (classesv
, size
), connected
) of
477 NONE
=> raise (accross state
)
480 List.tabulate (size
, fn v
=> v
),
483 folder (size
, connected
, state
)
485 then raise (accross state
)
488 else raise (accross state
))
489 in foldOverGraphs (eFolder
,
495 local fun final (size
: int, connected
: int * int -> bool): int =
500 if connected (from
, to
)
507 fn (size
, connected
, state
) =>
508 if final (size
, connected
) = 0
515 print (arg ^
" -> ");
516 case Int.fromString arg
of
518 print ((Int.toString (f n
)) ^
"\n")
520 print
"NOT A NUMBER\n")
525 List.app doOne
["0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11"]