# Paste: My first Factor program: The Flow Augmentation algorithm for Transportation Networks ( see http://en.wikipedia.org/wiki/Transportation_network_(graph_theory) )

Author: Tom Weeks factor Wed, 18 Nov 2009 06:24:27
Plain Text |
```! Tom Weeks - Math 2051, Section 01
! u06a2 (2009.11.15) - Programming Project 2 (Page 400)
!
! For a given transportation network, determine a maximal flow
! by repeated use of the flow augmentation algorithm, starting
! with the flow that is zero along every arc.

USING: accessors arrays combinators combinators.short-circuit
io kernel math math.order math.parser prettyprint
sequences sorting strings ;
IN: u06a2

TUPLE: arc { from-to   pair    initial: { "" "" } }
{ capacity  real                       }
{ flow      real                       } ;

TUPLE: label { predecessor string  }
{ +/-         string  }
{ flow-delta  real    } ;

TUPLE: vertex { name     string  }
{ label    label   }
{ scanned? boolean }
{ labeled# integer } ; ! 0 means unlabeled

TUPLE: network { vertices array }
{ arcs     array } ;

: vertex-names ( network -- v-names )
vertices>> [ name>> ] map ;

: vertex-pairs ( network -- v-pairs )
arcs>> [ from-to>> ] map ;

: predecessors ( network -- v-names )
vertex-pairs [ first ] map ;

: successors ( network -- v-names )
vertex-pairs [ second ] map ;

: this-vertex ( v-name network -- v )
vertices>> [ name>> over = ] find 2nip ;

: source-name ( network -- v-name )
[ successors ] [ vertex-names ] bi
[ over member? not ] find 2nip ;

: sink-name ( network -- v-name )
[ predecessors ] [ vertex-names ] bi
[ over member? not ] find 2nip ;

: source ( network -- v ) [ source-name ] keep this-vertex ;

: sink ( network -- v ) [ sink-name ] keep this-vertex ;

: infinity ( -- n ) 2 26 shift dup 1 - + ; inline ! fixnum max

: <label> ( predecessor +/- flow-delta -- label ) label boa ;

: label-source ( network -- network' )
dup source "source" "+" infinity <label> >>label
1 swap (>>labeled#) ;

: labeled? ( v -- ? ) labeled#>> 0 > ;

: scanned? ( v -- ? ) scanned?>> ;

: labeled ( network -- vs ) vertices>> [ labeled? ] filter ;

: unlabeled ( network -- vs )
vertices>> [ labeled? not ] filter ;

: highest-labeled# ( network -- n )
vertices>> [ labeled#>> ] map natural-sort last ;

: next-label# ( network -- n ) highest-labeled# 1 + ;

: >name-pair ( v w -- v-pair ) [ name>> ] bi@ 2array ;

: is-arc? ( network v w -- ? )
>name-pair swap arcs>> [ from-to>> ] map member? ;

: this-arc ( network v w -- arc )
>name-pair swap arcs>> [ from-to>> over = ] filter first
nip ;

: capacity-remaining ( arc -- n )
[ capacity>> ] [ flow>> ] bi - ;

: capacity-remaining? ( arc -- ? ) capacity-remaining 0 > ;

: is-arc-and-capacity-remaining? ( network v w -- ? )
{ [ is-arc? ] [ this-arc capacity-remaining? ] } 3&& ;

: is-arc-and-flow>0? ( network v w -- ? )
{ [ is-arc? ] [ this-arc flow>> 0 > ] } 3&& ;

: min(v-flow-delta,w-capacity-remaining) ( network v w -- n )
[ this-arc capacity-remaining ] 2keep
drop label>> flow-delta>>
min ;

: min(v-flow-delta,w-to-v-flow) ( network v w -- n )
[ swap this-arc flow>> ] 2keep
drop label>> flow-delta>>
min ;

: maybe-label-vertex ( network v w -- )
{ { [ 3dup is-arc-and-capacity-remaining? ]
[ 3dup min(v-flow-delta,w-capacity-remaining)
[ over name>> "+" ] dip <label> >>label
pick next-label# >>labeled# ] }
{ [ 3dup swap is-arc-and-flow>0? ]
[ 3dup min(v-flow-delta,w-to-v-flow)
[ over name>> "-" ] dip <label> >>label
pick next-label# >>labeled# ] }
[ ]
} cond 3drop ;

: label-some-neighbors ( network v unlabeled -- network' )
dup empty?
[ drop t >>scanned? drop ]
[ 3dup first maybe-label-vertex rest label-some-neighbors ]
if ;

: first-labeled ( vs -- v ) [ labeled#>> ] sort-with first ;

: select-vertex-to-scan ( network -- v )
vertices>>
[ [ labeled? ] [ scanned? not ] bi and ] filter
first-labeled ;

: scan-again? ( network -- ? )
[ sink labeled? ]
[ labeled [ scanned? ] all? ] bi or not ;

: scan-and-label ( network -- network' )
dup [ select-vertex-to-scan ] [ unlabeled ] bi
label-some-neighbors
dup scan-again? [ scan-and-label ] when ;

: adjust-flow ( network v -- network' v' )
dup label>> dup +/->> "+" =
[ predecessor>> pick this-vertex 3dup swap this-arc
[ nip ] dip pick sink label>> flow-delta>>
over flow>> + >>flow ]
[ predecessor>> pick this-vertex 3dup this-arc
[ nip ] dip pick sink label>> flow-delta>>
over flow>> swap - >>flow ]
if drop over source over = [ adjust-flow ] unless ;

: increase-flow ( network -- network'/f )
dup sink labeled? not
[ drop f ] ! This flow is already a maximal flow.
[ dup sink adjust-flow drop ]
if ;

: augment-flow ( network -- network'/f )
label-source scan-and-label increase-flow ;

: delete-labels ( network -- network' )
dup vertices>>
[ T{ label } >>label
f >>scanned?
0 >>labeled# ]
map drop ;

: print-vertex ( v -- )
dup name>> ": " append write
label>>
"(" write
[ predecessor>> "," append ]
[ +/->> "," append ]
[ flow-delta>> number>string ")" append ]
tri [ write ] tri@ nl ;

: print-vertices ( network -- )
"Vertices: " print vertices>> [ print-vertex ] each ;

: print-arc ( arc -- )
dup from-to>>
[ first "," append write ] [ second ": " append write ] bi
[ capacity>> number>string "," append write ]
[ flow>> number>string print ]
bi ;

: print-arcs ( network -- )
"Arcs: " print arcs>> [ print-arc ] each ;

: print-network ( network iteration# -- )
"============" print
[ "Iteration " ] dip number>string ": " [ write ]
tri@ nl "============" print nl
[ print-vertices nl ] [ print-arcs ] bi nl nl ;

: maximize-flow' ( network iteration# -- network' iteration# )
1 + over augment-flow
[ 2dup print-network
[ delete-labels ] dip maximize-flow' ]
when ;

: maximize-flow ( network -- ) 0 maximize-flow' 2drop ;

: fig7.12 ( -- network ) ! p.372
T{ network f { T{ vertex f "A" }
T{ vertex f "B" }
T{ vertex f "C" }
T{ vertex f "D" }
T{ vertex f "E" } }
{ T{ arc f { "A" "B" } 6 }
T{ arc f { "A" "C" } 8 }
T{ arc f { "A" "D" } 3 }
T{ arc f { "B" "C" } 5 }
T{ arc f { "B" "D" } 6 }
T{ arc f { "C" "E" } 4 }
T{ arc f { "D" "E" } 9 } } } ;

: fig7.21 ( -- network ) ! p.375
T{ network f { T{ vertex f "A" }
T{ vertex f "B" }
T{ vertex f "C" }
T{ vertex f "D" }
T{ vertex f "E" }
T{ vertex f "F" }
T{ vertex f "G" } }
{ T{ arc f { "A" "B" } 5 }
T{ arc f { "A" "C" } 7 }
T{ arc f { "A" "D" } 4 }
T{ arc f { "B" "C" } 1 }
T{ arc f { "B" "F" } 3 }
T{ arc f { "C" "D" } 2 }
T{ arc f { "C" "E" } 5 }
T{ arc f { "C" "F" } 4 }
T{ arc f { "D" "E" } 4 }
T{ arc f { "E" "F" } 1 }
T{ arc f { "E" "G" } 6 }
T{ arc f { "F" "G" } 9 } } } ;

: 7.2problem2 ( -- network ) ! p.379
T{ network f { T{ vertex f "A" }
T{ vertex f "B" }
T{ vertex f "C" }
T{ vertex f "D" }
T{ vertex f "E" } }
{ T{ arc f { "A" "B" } 6.8 4.2 }
T{ arc f { "A" "C" } 2.2 1.8 }
T{ arc f { "A" "D" } 3.1 1.5 }
T{ arc f { "B" "C" } 5.2 3.3 }
T{ arc f { "B" "D" } 1.5 0.9 }
T{ arc f { "C" "E" } 7.6 5.1 }
T{ arc f { "D" "E" } 3.2 2.4 } } } ;

: 7.2problem8 ( -- network ) ! p.379
T{ network f
{ T{ vertex f "A" T{ label f "B" "-" 1 } t 2 }
T{ vertex f "B" T{ label f "D" "+" 4 } t 3 }
T{ vertex f "C" T{ label f "B" "-" 3 } t 4 }
T{ vertex f "D" T{ label f "source" "+" 268435455 } t 1 }
T{ vertex f "E" T{ label f "C" "-" 3 } t 5 }
T{ vertex f "F" T{ label f "E" "+" 3 } f 6 } }
{ T{ arc f { "A" "B" } 2 1 }
T{ arc f { "B" "E" } 7 7 }
T{ arc f { "C" "A" } 3 1 }
T{ arc f { "C" "B" } 5 3 }
T{ arc f { "D" "B" } 7 3 }
T{ arc f { "D" "E" } 1 1 }
T{ arc f { "D" "F" } 6 6 }
T{ arc f { "E" "C" } 4 4 }
T{ arc f { "E" "F" } 8 4 } } } ;

: 7.2problem11 ( -- network ) ! p.380
T{ network f
{ T{ vertex f "A" }
T{ vertex f "B" }
T{ vertex f "C" }
T{ vertex f "D" }
T{ vertex f "E" }
T{ vertex f "F" } }
{ T{ arc f { "A" "B" } 10 8 }
T{ arc f { "A" "C" } 6 4 }
T{ arc f { "B" "D" } 7 5 }
T{ arc f { "B" "E" } 4 4 }
T{ arc f { "C" "B" } 3 1 }
T{ arc f { "C" "E" } 3 3 }
T{ arc f { "D" "E" } 2 2 }
T{ arc f { "D" "F" } 3 3 }
T{ arc f { "E" "F" } 11 9 } } } ;

: 7.3problem8 ( -- network ) ! p.386
T{ network f
{ T{ vertex f "A" T{ label f } }
T{ vertex f "B" T{ label f } }
T{ vertex f "C" T{ label f } }
T{ vertex f "D" T{ label f } }
T{ vertex f "E" T{ label f } }
T{ vertex f "F" T{ label f } } }
{ T{ arc f { "A" "B" } 3 3 }
T{ arc f { "A" "C" } 4 4 }
T{ arc f { "A" "D" } 5 2 }
T{ arc f { "B" "E" } 7 3 }
T{ arc f { "D" "B" } 2 0 }
T{ arc f { "D" "F" } 2 2 }
T{ arc f { "E" "C" } 2 2 }
T{ arc f { "E" "F" } 4 1 }
T{ arc f { "F" "C" } 3 3 } } } ;

: 7.4problem16 ( -- network ) ! p.395
T{ network f { T{ vertex f "C" }
T{ vertex f "D" }
T{ vertex f "E" }
T{ vertex f "F" }
T{ vertex f "G" }
T{ vertex f "S" }
T{ vertex f "T" }
T{ vertex f "U" }
T{ vertex f "V" }
T{ vertex f "W" }
T{ vertex f "s" }
T{ vertex f "t" } }
{ T{ arc f { "s" "S" } 1 }
T{ arc f { "s" "T" } 1 }
T{ arc f { "s" "U" } 1 }
T{ arc f { "s" "V" } 1 }
T{ arc f { "s" "W" } 1 }
T{ arc f { "C" "t" } 1 }
T{ arc f { "D" "t" } 1 }
T{ arc f { "E" "t" } 1 }
T{ arc f { "F" "t" } 1 }
T{ arc f { "G" "t" } 1 }
T{ arc f { "S" "E" } 1 }
T{ arc f { "S" "F" } 1 }
T{ arc f { "T" "C" } 1 }
T{ arc f { "T" "D" } 1 }
T{ arc f { "T" "G" } 1 }
T{ arc f { "U" "E" } 1 }
T{ arc f { "U" "F" } 1 }
T{ arc f { "V" "C" } 1 }
T{ arc f { "V" "D" } 1 }
T{ arc f { "V" "F" } 1 }
T{ arc f { "V" "G" } 1 }
T{ arc f { "W" "C" } 1 }
T{ arc f { "W" "E" } 1 }
T{ arc f { "W" "F" } 1 } } } ;

: 7.4problem22 ( -- network ) ! p.395
T{ network f { T{ vertex f "A" }
T{ vertex f "B" }
T{ vertex f "C" }
T{ vertex f "D" }
T{ vertex f "E" }
T{ vertex f "F" }
T{ vertex f "G" }
T{ vertex f "H" }
T{ vertex f "I" }
T{ vertex f "J" }
T{ vertex f "s" }
T{ vertex f "t" } }
{ T{ arc f { "s" "A" } 1 }
T{ arc f { "s" "B" } 1 }
T{ arc f { "s" "C" } 1 }
T{ arc f { "s" "D" } 1 }
T{ arc f { "s" "E" } 1 }
T{ arc f { "F" "t" } 1 }
T{ arc f { "G" "t" } 1 }
T{ arc f { "H" "t" } 1 }
T{ arc f { "I" "t" } 1 }
T{ arc f { "J" "t" } 1 }
T{ arc f { "A" "G" } 1 }
T{ arc f { "A" "H" } 1 }
T{ arc f { "B" "F" } 1 }
T{ arc f { "B" "I" } 1 }
T{ arc f { "C" "H" } 1 }
T{ arc f { "C" "J" } 1 }
T{ arc f { "D" "F" } 1 }
T{ arc f { "D" "G" } 1 }
T{ arc f { "E" "G" } 1 }
T{ arc f { "E" "I" } 1 } } } ;

: demo ( -- ) "
=========================
| Figure 7.12, Page 372 |
=========================\n" print
fig7.12 dup 0 print-network maximize-flow
nl nl "
=========================
| Figure 7.21, Page 375 |
=========================\n" print
fig7.21 dup 0 print-network maximize-flow
nl nl "
============================
| Exercises 7.2, Problem 2 |
============================\n" print
7.2problem2 dup 0 print-network maximize-flow
nl nl "
============================
| Exercises 7.2, Problem 8 |
============================\n" print
7.2problem8 dup 0 print-network
increase-flow 1 print-network
nl nl "
=============================
| Exercises 7.2, Problem 11 |
=============================\n" print
7.2problem11 dup 0 print-network maximize-flow
nl nl "
============================
| Exercises 7.3, Problem 8 |
============================\n" print
7.3problem8 dup 0 print-network
label-source scan-and-label 1 print-network
nl nl "
=============================
| Exercises 7.4, Problem 16 |
=============================\n" print
7.4problem16 dup 0 print-network maximize-flow
nl nl "
=============================
| Exercises 7.4, Problem 22 |
=============================\n" print
7.4problem22 dup 0 print-network maximize-flow ;

MAIN: demo```