\ processing equivalence classes
\
\ Copyright (C) 2011 David K端hling <dvdkhlng TA gmx TOD de>
\
\ 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
<private>
0 VALUE equiv-map{
0 VALUE adjmap{{
0 VALUE class
<public>
: (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]