## [r2]: trunk / equiv.fs History

Child: [r3] (diff)

 ``` 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132``` ```\ processing equivalence classes \ \ Copyright (C) 2011 David K端hling \ \ License: GPL3 or later, NO WARRANTY \ \ Created: Aug 2011 require ./matrix.fs require ./graph.fs require ./module.fs module equiv : }equivs>protomap { #equivs equivs{ #elts map{ -- } \ deprecated: \ Generate a map from elements to prototypes for an equivalence relation. \ \ Input: An equivalence relation on integers in 0..#elts-1, defined by the \ '#equivs' pair-wise equivalences in equivs{}. stored as double vector \ equivs{} \ \ Output: map{} from the integers referred to by equivs{} to the lowest \ integer of the corresponding equivalence class (i.e. the "prototypes"). \ \ When done, map{} contains as many unique elements, as there are \ equivalence classes. However, unique element IDs refered to by map{} \ arre still not numbered in sequence, i.e. "holes" are possible. \ todo: could use }edges>adjmap and perform breadth-first search on equiv. \ graph? \ initialize map{} to identity #elts 0 DO I map{ I } ! LOOP \ iteratively adjust map{} to refer to the lowest equivalent elements \ for all equivalence pairs. BEGIN true { done } \ iterate over equivalence classes and adjust map{} whenever two mapped \ elts in a pair still differ. we're done if no adjustment was \ neccessary #equivs 0 DO equivs{ I } 2@ map{ SWAP } map{ ROT } { c1 c2 } c1 @ c2 @ 2DUP <> IF MIN DUP c1 ! c2 ! false TO done ELSE 2DROP THEN LOOP done UNTIL ; : }protomap>idmap { #elts map{ -- #classes } \ deprecated: \ From a prototype map generated by }equivs>protomap, generate a \ corresponding map that maps to integers 0..nclasses-1. Note that new IDs \ have same order as prototype integer values. #elts 0 DO \ find lowest prototype >= I (i.e. not yet renumbered) #elts #elts 0 DO map{ I } @ DUP J >= IF MIN ELSE DROP THEN LOOP \ if no prototype greater I exists we're done DUP #elts = IF DROP I UNLOOP EXIT THEN \ replace next greater prototype with I DUP I <> IF #elts 0 DO DUP map{ I } @ = IF J map{ I } ! THEN LOOP THEN DROP LOOP \ this code is only reached if nothing has been renumbered (i.e. input \ was already a proper idmap) #elts ; \ static variables used like local variables in (mark-equiv-class) \ pulled out here to reduce locals stack usage during recursion 0 VALUE equiv-map{ 0 VALUE adjmap{{ 0 VALUE class : (mark-equiv-class) ( node -- ) \ spanning tree algorithm to mark all connected nodes equivalent to \ global variable 'class' adjmap{{ SWAP } 2@ \ iterate over neighbours of node 0 ?DO ( s: neighbours{ ) DUP I } @ 1abs ( s: neighbours{ neighbour ) equiv-map{ OVER } DUP @ 0< IF class SWAP ! RECURSE ELSE 2DROP THEN LOOP DROP ; : }equivs>idmap { #equivs equivs{ #elts map{ -- #classes } \ Generate a map from elements to prototypes for an equivalence relation. \ \ Input: An equivalence relation on integers in 0..#elts-1, defined by the \ '#equivs' pair-wise equivalences in equivs{}. stored as double vector \ equivs{} \ \ Output: map{} from the integers referred to by equivs{} to class-labels \ 0..#classes-1. Class labels are in same order as id of the lowest elment \ in the class map{ TO equiv-map{ #elts #equivs equivs{ }edges>adjmap TO adjmap{{ #elts 0 DO -1 map{ I } ! LOOP \ fill map (mark nodes as non-seen) 0 TO class #elts 0 DO \ iterate over nodes, assigning class-ids map{ I } @ 0< IF class map{ I } ! \ start node I belongs to class I (mark-equiv-class) class 1+ TO class THEN LOOP adjmap{{ }unallot class ; end-module \ Customize Emacs 0 [IF] Local Variables: compile-command: "gforth equiv-test.fs -e bye" End: [THEN] ```