Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Written by Henry Cejtin (henry@sourcelight.com). *) |
2 | ||
3 | fun print _ = () | |
4 | ||
5 | (* | |
6 | * My favorite high-order procedure. | |
7 | *) | |
8 | fun fold (lst, folder, state) = | |
9 | let fun loop (lst, state) = | |
10 | case lst of | |
11 | [] => state | |
12 | | first::rest => loop (rest, folder (first, state)) | |
13 | in loop (lst, state) | |
14 | end | |
15 | ||
16 | fun naturalFold (limit, folder, state) = | |
17 | if limit < 0 | |
18 | then raise Domain | |
19 | else let fun loop (i, state) = | |
20 | if i = limit | |
21 | then state | |
22 | else loop (i+1, folder (i, state)) | |
23 | in loop (0, state) | |
24 | end | |
25 | ||
26 | fun naturalAny (limit, ok) = | |
27 | if limit < 0 | |
28 | then raise Domain | |
29 | else let fun loop i = | |
30 | i <> limit andalso | |
31 | (ok i orelse loop (i+1)) | |
32 | in loop 0 | |
33 | end | |
34 | ||
35 | fun naturalAll (limit, ok) = | |
36 | if limit < 0 | |
37 | then raise Domain | |
38 | else let fun loop i = | |
39 | i = limit orelse | |
40 | (ok i andalso loop (i+1)) | |
41 | in loop 0 | |
42 | end | |
43 | (* | |
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 | |
57 | * via | |
58 | * folder (pState, state) | |
59 | * where pState is the final pState and state is the current state. | |
60 | * It should return the new state. | |
61 | *) | |
62 | fun 'a foldOverPermutations (universe, pFolder, pState, folder, state: 'a) = | |
63 | let exception accross of 'a | |
64 | fun outer (universe, pState, state) = | |
65 | case universe of | |
66 | [] => folder (pState, state) | |
67 | | first::rest => | |
68 | let fun inner (first, rest, revOut, state) = | |
69 | let val state = | |
70 | let val (newPState, state) = | |
71 | pFolder (first, | |
72 | pState, | |
73 | state, | |
74 | accross) | |
75 | in outer (fold (revOut, | |
76 | op ::, | |
77 | rest), | |
78 | newPState, | |
79 | state) | |
80 | end handle accross state => state | |
81 | in case rest of | |
82 | [] => state | |
83 | | second::rest => | |
84 | inner (second, | |
85 | rest, | |
86 | first::revOut, | |
87 | state) | |
88 | end | |
89 | in inner (first, rest, [], state) | |
90 | end | |
91 | in outer (universe, pState, state) | |
92 | end | |
93 | (* | |
94 | * Fold over all arrangements of bag elements. | |
95 | * Universe is a list of lists of items, with equivalent items in the | |
96 | * same list. | |
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 | |
108 | * via | |
109 | * folder (pState, state) | |
110 | * where pState is the final pState and state is the current state. | |
111 | * It should return the new state. | |
112 | *) | |
113 | fun 'a foldOverBagPerms (universe, pFolder, pState, folder, state: 'a) = | |
114 | let exception accross of 'a | |
115 | fun outer (universe, pState, state) = | |
116 | case universe of | |
117 | [] => folder (pState, state) | |
118 | | (fbag as (first::fclone))::rest => | |
119 | let fun inner (fbag, first, fclone, rest, revOut, state) = | |
120 | let val state = | |
121 | let val (newPState, state) = | |
122 | pFolder (first, | |
123 | pState, | |
124 | state, | |
125 | accross) | |
126 | in outer (fold (revOut, | |
127 | op ::, | |
128 | case fclone of | |
129 | [] => rest | |
130 | | _ => fclone::rest), | |
131 | newPState, | |
132 | state) | |
133 | end handle accross state => state | |
134 | in case rest of | |
135 | [] => state | |
136 | | (sbag as (second::sclone))::rest => | |
137 | inner (sbag, | |
138 | second, | |
139 | sclone, | |
140 | rest, | |
141 | fbag::revOut, | |
142 | state) | |
143 | end | |
144 | in inner (fbag, first, fclone, rest, [], state) | |
145 | end | |
146 | in outer (universe, pState, state) | |
147 | end | |
148 | (* | |
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 | |
157 | * fini newState | |
158 | * If we need to proceed deeper in the tree, then eFolder should return | |
159 | * the tuple | |
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. | |
167 | *) | |
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) = | |
172 | eFolder (first, | |
173 | isinc, | |
174 | eState, | |
175 | state, | |
176 | fini) | |
177 | in outer (rest, newEState, newState) | |
178 | end handle fini state => state | |
179 | and outer (universe, eState, state) = | |
180 | case universe of | |
181 | [] => folder (eState, state) | |
182 | | first::rest => | |
183 | let val f = f (first, rest, eState) | |
184 | in f (false, f (true, state)) | |
185 | end | |
186 | in outer (universe, eState, state) | |
187 | end | |
188 | ||
189 | fun f universe = | |
190 | foldOverSubsets (universe, | |
191 | fn (elem, isinc, set, state, _) => | |
192 | (if isinc | |
193 | then elem::set | |
194 | else set, | |
195 | state), | |
196 | [], | |
197 | fn (set, sets) => set::sets, | |
198 | []) | |
199 | (* | |
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). | |
210 | *) | |
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. *) | |
216 | naturalAll (size, | |
217 | fn y => connected (size, y) = | |
218 | connected (x, | |
219 | if y = x | |
220 | then size | |
221 | else y)) | |
222 | fun merge (class, (merged, classes)) = | |
223 | (* Add class into classes, testing if size should be merged. *) | |
224 | if merged | |
225 | then (true, (rev class)::classes) | |
226 | else let val first::_ = class | |
227 | in if sizeMatch first | |
228 | then (true, fold (class, | |
229 | op ::, | |
230 | [size])::classes) | |
231 | else (false, (rev class)::classes) | |
232 | end | |
233 | fun split (elem, (yes, no)) = | |
234 | if connected (elem, size) | |
235 | then (elem::yes, no) | |
236 | else (yes, elem::no) | |
237 | fun subdivide (class, state) = | |
238 | case class of | |
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]]) | |
247 | end | |
248 | (* | |
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. | |
254 | * If it is, return | |
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: | |
260 | * - | |
261 | * 0 - | |
262 | * 1 2 - | |
263 | * 3 4 5 - | |
264 | * ... | |
265 | * Note, the vertices are the integers in [0, nverts). | |
266 | *) | |
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) | |
271 | exception fini | |
272 | fun pFolder (new, old, state, accross) = | |
273 | let fun loop v = | |
274 | if v = old | |
275 | then (Array.update (perm, old, new); | |
276 | (old + 1, state)) | |
277 | else case (connected (old, | |
278 | v), | |
279 | connected (new, | |
280 | Array.sub (perm, | |
281 | v))) of | |
282 | (true, false) => | |
283 | raise (accross state) | |
284 | | (false, true) => | |
285 | raise fini | |
286 | | _ => | |
287 | loop (v + 1) | |
288 | in loop 0 | |
289 | end | |
290 | fun folder (_, state) = | |
291 | state + 1 | |
292 | in SOME (foldOverBagPerms ( | |
293 | classes, | |
294 | pFolder, | |
295 | 0, | |
296 | folder, | |
297 | 0)) handle fini => NONE | |
298 | end | |
299 | (* | |
300 | * Fold over the tree of graphs. | |
301 | * | |
302 | * eFolder is used to fold over the choice of edges via | |
303 | * eFolder (from, to, isinc, eState, state, accross) | |
304 | * with from > to. | |
305 | * | |
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. | |
309 | * | |
310 | * To continue normally, it should return the tuple | |
311 | * (newEState, newState) | |
312 | * | |
313 | * When all decisions are made with regards to edges from `from', folder | |
314 | * is called via | |
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'. | |
318 | * | |
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. | |
321 | * | |
322 | * If extensions of this graph should be folded over, it should return | |
323 | * the new state. | |
324 | *) | |
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, | |
329 | fn nverts => | |
330 | List.tabulate (nverts, | |
331 | fn v => v)) | |
332 | val vertss = ref (makeVertss 0) | |
333 | fun findVerts size = ( | |
334 | if size >= Vector.length (!vertss) | |
335 | then vertss := makeVertss (size + 1) | |
336 | else (); | |
337 | Vector.sub (!vertss, size)) | |
338 | fun f (size, eState, state) = | |
339 | let val state = | |
340 | folder (size, eState, state, noextend) | |
341 | in g (size+1, state) | |
342 | end handle noextend state => state | |
343 | and g (size, state) = | |
344 | let val indices = | |
345 | findVerts (size - 1) | |
346 | fun SeFolder (to, isinc, eState, state, accross) = | |
347 | eFolder (size-1, | |
348 | to, | |
349 | isinc, | |
350 | eState, | |
351 | state, | |
352 | accross) | |
353 | fun Sf (eState, state) = | |
354 | f (size, eState, state) | |
355 | in foldOverSubsets ( | |
356 | indices, | |
357 | SeFolder, | |
358 | eState, | |
359 | Sf, | |
360 | state) | |
361 | end | |
362 | in f (0, eState, state) | |
363 | end | |
364 | ||
365 | (* | |
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. | |
370 | *) | |
371 | local fun short lst = | |
372 | case lst of | |
373 | [] => true | |
374 | | [_] => true | |
375 | | _ => false | |
376 | in fun okSoFar (size, verts, connected) = | |
377 | let exception fini of unit | |
378 | fun eFolder (elem, isinc, eState as (ac, picked), _, accross) = | |
379 | (if isinc | |
380 | then (fold (picked, | |
381 | fn (p, ac) => | |
382 | if connected (elem, p) | |
383 | then ac - 2 | |
384 | else ac, | |
385 | ac + 3), | |
386 | elem::picked) | |
387 | else eState, | |
388 | ()) | |
389 | fun folder ((ac, picked), state) = | |
390 | if ac >= 0 orelse short picked | |
391 | then state | |
392 | else raise (fini ()) | |
393 | in (foldOverSubsets ( | |
394 | verts, | |
395 | eFolder, | |
396 | (~4, []), | |
397 | folder, | |
398 | ()); | |
399 | true) handle fini () => false | |
400 | end | |
401 | end | |
402 | ||
403 | fun showGraph (size, connected) = | |
404 | naturalFold (size, | |
405 | fn (from, _) => ( | |
406 | print ((Int.toString from) ^ ":"); | |
407 | naturalFold (size, | |
408 | fn (to, _) => | |
409 | if from <> to andalso connected (from, to) | |
410 | then print (" " ^ (Int.toString to)) | |
411 | else (), | |
412 | ()); | |
413 | print "\n"), | |
414 | ()); | |
415 | ||
416 | fun showList (start, sep, stop, trans) lst = ( | |
417 | start (); | |
418 | case lst of | |
419 | [] => () | |
420 | | first::rest => ( | |
421 | trans first; | |
422 | fold (rest, | |
423 | fn (item, _) => ( | |
424 | sep (); | |
425 | trans item), | |
426 | ())); | |
427 | stop ()) | |
428 | ||
429 | val showIntList = showList ( | |
430 | fn () => print "[", | |
431 | fn () => print ", ", | |
432 | fn () => print "]", | |
433 | fn i => print (Int.toString i)) | |
434 | ||
435 | val showIntListList = showList ( | |
436 | fn () => print "[", | |
437 | fn () => print ", ", | |
438 | fn () => print "]", | |
439 | showIntList) | |
440 | ||
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 | |
447 | then (from, to) | |
448 | else (to, from) | |
449 | in Array.sub (Array.sub (ctab, from), to) | |
450 | end | |
451 | fun update (from, to, value) = | |
452 | let val (from, to) = if from > to | |
453 | then (from, to) | |
454 | else (to, from) | |
455 | in Array.update (Array.sub (ctab, from), to, value) | |
456 | end | |
457 | fun triangle (vnum, e) = | |
458 | naturalAny (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) | |
464 | else ( | |
465 | update (from, to, isinc); | |
466 | ((), state)) | |
467 | fun Gfolder (size, _, state, accross) = ( | |
468 | if size <> 0 | |
469 | then Array.update (classesv, | |
470 | size, | |
471 | refine (size-1, | |
472 | Array.sub (classesv, | |
473 | size-1), | |
474 | connected)) | |
475 | else (); | |
476 | case minimal (size, Array.sub (classesv, size), connected) of | |
477 | NONE => raise (accross state) | |
478 | | SOME eatMe => | |
479 | if okSoFar (size, | |
480 | List.tabulate (size, fn v => v), | |
481 | connected) | |
482 | then let val state = | |
483 | folder (size, connected, state) | |
484 | in if size = maxSize | |
485 | then raise (accross state) | |
486 | else state | |
487 | end | |
488 | else raise (accross state)) | |
489 | in foldOverGraphs (eFolder, | |
490 | (), | |
491 | Gfolder, | |
492 | state) | |
493 | end | |
494 | ||
495 | local fun final (size: int, connected: int * int -> bool): int = | |
496 | naturalFold (size, | |
497 | fn (from, ac) => | |
498 | naturalFold (from, | |
499 | fn (to, ac) => | |
500 | if connected (from, to) | |
501 | then ac - 2 | |
502 | else ac, | |
503 | ac), | |
504 | 3*size - 4) | |
505 | in fun f maxSize = | |
506 | h (maxSize, | |
507 | fn (size, connected, state) => | |
508 | if final (size, connected) = 0 | |
509 | then state + 1 | |
510 | else state, | |
511 | 0) | |
512 | end | |
513 | ||
514 | fun doOne arg = ( | |
515 | print (arg ^ " -> "); | |
516 | case Int.fromString arg of | |
517 | SOME n => | |
518 | print ((Int.toString (f n)) ^ "\n") | |
519 | | NONE => | |
520 | print "NOT A NUMBER\n") | |
521 | ||
522 | structure Main = | |
523 | struct | |
524 | fun doit() = | |
525 | List.app doOne ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11"] | |
526 | ||
527 | val doit = | |
528 | fn size => | |
529 | let | |
530 | fun loop n = | |
531 | if n = 0 | |
532 | then () | |
533 | else (doit(); | |
534 | loop(n-1)) | |
535 | in loop size | |
536 | end | |
537 | end |