This page was automatically generated by NetLogo 5.0.4.
The applet requires Java 5 or higher. Java must be enabled in your browser settings. Mac users must have Mac OS X 10.4 or higher. Windows and Linux users may obtain the latest Java from Oracle's Java site.
In order for this to work, this file, your model file (ADOPTgc.nlogo), and the files NetLogoLite.jar and NetLogoLite.jar.pack.gz must all be in the same directory. (You can copy NetLogoLite.jar and NetLogoLite.jar.pack.gz from the directory where you installed NetLogo.)
On some systems, you can test the applet locally on your computer before uploading it to a web server. It doesn't work on all systems, though, so if it doesn't work from your hard drive, please try uploading it to a web server.
You don't need to include everything in this file in your page. If you want, you can just take the HTML code beginning with <applet> and ending with </applet>, and paste it into any HTML file you want. It's even OK to put multiple <applet> tags on a single page.
If the NetLogoLite files and your model are in different directories, you must modify the archive= and value= lines in the HTML code to point to their actual locations. (For example, if you have multiple applets in different directories on the same web server, you may want to put a single copy of the NetLogoLite files in one central place and change the archive= lines of all the HTML files to point to that one central copy. This will save disk space for you and download time for your users.)
powered by NetLogo
view/download model file: ADOPTgc.nlogo
Title: Graph Coloring using Adopt
Author: Jose M Vidal and Ionel Muscalagiu
Description:
We solve the graph coloring problem using the
Adopt algorithm from
The tree is rooted at the top of the screen. All the lines between nodes
represent constraints. The light-colored lines (cyan) are also the parent-child
links on the tree. The color of the node is, well, the current color of the node.
The numbers on each node represent the LB-threshold-UB:ID.
;Graph coloring using distributed algorithms
;Uses Adopt, from AAMAS03
;by Jose Vidal and Ionel Muscalagiu
breed [ nodes ]
breed [ context-agents ]
;edges is a list of lists: a 2D array indexed by who. The value is 1 if there is a link, 0 otherwise.
;num-colors
;domain is the list of allowed colors
globals [edges domain time tot-edges ]
;parent is the 'who' of the parent
;parent-agent is the actual parent
;children is a list of the 'who' of the children
;children-agent is an agentset of the children
;level in the tree. root is 0
;descendant-neighbors is a list of the 'who' of all nodes that are descendants and have a constraint with me
;neighbors-list is a list of the 'who' of all nodes that have a constraint with me
;dfs-neighbors is like above but might include others, it is used by the dfs-tree algorithm of Modi.
;threshold- as in paper
;current-context is CurrentContext from the paper
;lbounds is lb(d_i,x_l)
;ubounds is ub(d_i,x_l)
;t
;context is context(d_i,x_l)
;terminate is set to true if received a terminate message
;dead is set to true if vertice has terminated execution
;d_i from the paper is represented by 'color'
;last-threshold-message is a list indexed by who were each item is the last threshold msg sent to that agent. [val current-context]
nodes-own [message-queue parent parent-agent children children-agent level descendant-neighbors
neighbors-list dfs-neighbors dfs-change threshold current-context lbounds ubounds t context
terminate dead messages-handled messages-received last-threshold-message context-display need-to-backtrack AgentC_Cost the-links]
;returns a list of legnth n where each item is v
to-report make-list [n v]
let res 0
set res []
repeat n [
set res fput v res]
report res
end
to-report lists-equal? [l1 l2]
let i 0
if (length l1 != length l2) [report false]
set i 0
while [i < length l1][
if (item i l1 != item i l2)[report false]
set i i + 1
]
report true
end
to make-link [v1 v2]
let tmp 0
if (v2 < v1)[
set tmp v2
set v2 v1
set v1 tmp]
if (not neighbors? v1 v2) [
set edges replace-item v1 edges (lput v2 (item v1 edges))
]
end
to-report neighbors? [v1 v2]
let tmp 0
if (v2 < v1) [
set tmp v2
set v2 v1
set v1 tmp]
report member? v2 (item v1 edges)
end
;reports true if edges and num-nodes represent a connected graph
to-report connected?
let clique 0
let i 0
let j 0
set i 0
set clique []
set clique lput i clique
set i 1
set j 0
while [j < num-nodes][
while [i < num-nodes][
if (not member? i clique)[
if (not empty? filter [neighbors? ? i] clique)[
set clique lput i clique
if (length clique = num-nodes)[
report true
]
]
]
set i i + 1
]
set j j + i
]
report false
end
to-report subgraph [n] ; report the complete connected subgraph containing n1
let stack 0
let graph 0
let nr 0
let ag 0
let vec 0
set graph (list turtle n)
set stack (list n)
while [length stack > 0] [
set ag first stack
foreach [the-links] of turtle ag[
if not member? turtle ? graph [
set graph lput turtle ? graph
set stack lput ? stack
]
]
set stack but-first stack
]
report graph
end
;sets 'edges' and 'neighbors-list'
to make-random-edges
let edges-created 0
let t1 0
let t2 0
let v1 0
let v2 0
let tmp 0
let g 0
ask nodes [
set neighbors-list []
]
set edges make-list num-nodes []
set edges-created 0
set g (list turtle 1)
while [length g < num-nodes] [
set t1 one-of nodes with [not member? self g]
ask t1 [set v1 who ]
set t2 item random length g g
ask t2 [set v2 who ]
if (v1 != v2 and (not neighbors? v1 v2))
[make-link v1 v2
ask t1 [set the-links lput v2 the-links]
ask t2 [set the-links lput v1 the-links]
set edges-created (edges-created + 1)
]
set g subgraph 1
;show g
]
while [edges-created < tot-edges] [
set t1 one-of nodes
ask t1 [set v1 who ]
set t2 one-of nodes with [self != t1 and not member? t1 the-links]
ask t2 [set v2 who ]
if v2 != nobody [make-link v1 v2
set edges-created (edges-created + 1)]
]
set v1 0
while [v1 < num-nodes][
set tmp (item v1 edges)
ask turtle v1 [ set neighbors-list [] ]
set v2 0
while [v2 < num-nodes][
if (neighbors? v1 v2)[
ask turtle v1 [ set neighbors-list lput v2 neighbors-list ]
]
set v2 v2 + 1
]
set v1 v1 + 1
]
end
to set-level
ifelse (parent = -1)[
set level 0
][
set level ([level] of parent-agent) + 1
]
end
;vertice function
to find-best-position
let possible-patches 0
let siblings 0
let best-patch 0
ifelse (parent = -1) [
set xcor 0
][
set siblings nodes with [self != myself and (level = [level] of myself or who = [parent] of myself)]
set possible-patches patches with [distance-nowrap myself < 20 and (pycor = round [ycor] of myself)]
set best-patch max-one-of possible-patches [sum [log (distance-nowrap myself + .1) 2] of siblings]
set xcor ([pxcor] of best-patch)
if (xcor < 0 + min-pxcor + 50) [set xcor 0 + min-pxcor + 50]
if (xcor > max-pxcor - 10) [set xcor max-pxcor - 10]
]
end
;nodes function. Draws an edge from this vertice to other-vertice
to draw-edge [other-vertice col]
let dista 0
let oc 0
let ox 0
let oy 0
set oc color
set ox xcor
set oy ycor
set color col
set dista distance-nowrap other-vertice
set heading towards-nowrap other-vertice
pen-down
fd dista
pen-up
set color oc
setxy ox oy
set heading 0
end
to draw-edges
let v1 0
set v1 0
while [v1 < num-nodes][
no-display
ask (turtle v1) [
without-interruption [
foreach neighbors-list [
draw-edge (turtle ?) blue
]
]
]
display
set v1 v1 + 1
]
;color tree differently
no-display
ask nodes [
if (parent >= 0)[
draw-edge parent-agent cyan
]
]
display
end
to setup-turtles
let i 0
;set num-colors 3
set domain []
set time 1
set tot-edges min list round (num-nodes * edge-density)
((num-nodes ^ 2 - num-nodes) / 2)
set i 0
while [i < num-colors][
set domain lput item i [15 105 64 125 45 85 35 55 5] domain
set i i + 1
]
;show num-nodes
create-nodes num-nodes
[
set size 30
set shape "circle"
set label who
set parent -2
set terminate false
set dead false
set lbounds make-map
set ubounds make-map
set t make-map
set context make-map
set the-links []
if (who != 0)[
set-current-plot "Messages"
create-temporary-plot-pen (word who)
set-plot-pen-color (5 + 10 * who) mod 140
set-current-plot "Message-queue"
create-temporary-plot-pen (word who)
set-plot-pen-color (5 + 10 * who) mod 140
]
; set color item (random-int-or-float num-colors) domain
set color item 0 domain
set messages-handled 0
]
end
to setup
let i 0
clear-output
clear-all
show "Setup"
setup-turtles
;make-edges
make-random-edges
set-dfs-tree
repeat num-nodes [
ask nodes [
set-level
]
]
;If there is only one root (level =0) then we have a tree.
if (not (count (nodes with [level = 0]) = 1))[
show "ERROR: more than 1 root...."]
set i max [level] of nodes
;show i
ask nodes [
ifelse ( level != i )
[ set ycor (max-pycor - 20) - (level * ((world-height - 30) / i))]
[ set ycor (max-pycor - 10) - (level * ((world-height - 30) / i))]
]
repeat 12 [
ask nodes [
find-best-position
]
]
draw-edges
;;set up the context display
create-context-agents num-nodes * num-nodes [
set size 8
set shape "circle"
set color black
]
ask nodes [
set context-display context-agents with [who >= (([who] of myself + 1) * num-nodes)
and who < (([who] of myself) + 2) * num-nodes]
]
set i 0
while [i < num-nodes][
ask ([context-display] of turtle i) [
set ycor ([ycor] of turtle i) + 15
set xcor ([xcor] of turtle i) - (5 * num-nodes) + 10 * (who - ((i + 1) * num-nodes))
set label(who - ((i + 1) * num-nodes))
]
set i i + 1
]
end
to setup-ADOPT
;;adopt::initialize
ask nodes [
set messages-received 0
set AgentC_Cost 0
initialize]
show "All initialized"
;reset-ticks
end
to update-contexts
let i 0
let c 0
set i 0
while [i < num-nodes][
ask ([context-display] of turtle i)[
set c item (who - (i + 1) * num-nodes) [current-context] of turtle i
ifelse (c = -1) [
set color black
][
set color c
]
]
set i i + 1
]
end
to go
let done 0
set time time + 1
if (show-messages) [print "===================="]
ask nodes [
handle-message
set label (word LB "-" threshold "-" UB ":" who)
set-current-plot "Messages"
set-current-plot-pen (word who)
plot messages-received]
update-contexts
ask nodes [
if (need-to-backtrack) [backtrack]
set-current-plot "Message-queue"
set-current-plot-pen (word who)
plot length message-queue
]
set done reduce [?1 and ?2] [dead] of nodes
type time
type "- "
ask nodes [
type position color domain
]
if (done) [stop]
end
to go-cycle
let done 0
if (show-messages) [print "===================="]
set time time + 1
ask nodes [
set need-to-backtrack false
set message-queue lput list "cycle" "done" message-queue]
set done (reduce [?1 and ?2] [dead or empty? message-queue or first first message-queue = "cycle"] of nodes)
while [not done][
ask nodes [
handle-message
set label (word LB "-" threshold "-" UB ":" who)
set-current-plot "Messages"
set-current-plot-pen (word who)
plot messages-received]
set done (reduce [?1 and ?2] [dead or empty? message-queue or first first message-queue = "cycle"] of nodes)
update-contexts
]
ask nodes [
if (not empty? message-queue and first first message-queue = "cycle") [
set message-queue butfirst message-queue
]
if (need-to-backtrack) [backtrack]
set-current-plot "Message-queue"
set-current-plot-pen (word who)
plot length message-queue
]
set done reduce [?1 and ?2] [dead] of nodes
type time
type "- "
ask nodes [
type position color domain
type " "
]
print ""
if (done) [stop]
end
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Map data structure
to-report make-map
report []
end
to-report get-triple-index [map-name key1 key2]
let i 0
set i 0
while [i < length map-name][
if (item 0 item i map-name = key1 and
item 1 item i map-name = key2) [
report i]
set i i + 1
]
report -1
end
to-report set-map-value [map-name key1 key2 value]
let triple-index 0
set triple-index get-triple-index map-name key1 key2
ifelse (triple-index = -1) [
report lput (list key1 key2 value) map-name
][
report replace-item triple-index map-name (list key1 key2 value)
]
end
to-report get-map-value [map-name key1 key2]
let i 0
set i 0
while [i < length map-name][
if (item 0 item i map-name = key1 and
item 1 item i map-name = key2) [
report item 2 item i map-name]
set i i + 1
]
report []
end
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Context data structure .
to-report make-context
report make-list num-nodes -1
end
to-report add-to-context [cont v val]
report replace-item v cont val
end
to-report remove-from-context [cont v]
report replace-item v cont -1
end
;a vertice function
to-report add-my-value-to-context [cont]
report replace-item who cont color
end
to-report compatible? [a b]
let i 0
set i 0
set AgentC_Cost AgentC_Cost + 1
while [i < num-nodes][
if (item i a != -1 and item i b != -1 and item i a != item i b)[
report false]
set i i + 1
]
report true
end
;assumes a and b are compatible
to-report union [a b]
let c 0
let i 0
set c make-context
set i 0
while [i < num-nodes][
if (item i a != -1) [
set c replace-item i c (item i a)]
if (item i b != -1) [
set c replace-item i c (item i b)]
set i i + 1
]
report c
end
;returns a list of the who of the agents in the context
to-report agents-in-context [cont]
let i 0
let res 0
set i 0
set res []
while [i < num-nodes][
if (item i cont != -1)[
set res lput i res
]
set i i + 1
]
report res
end
;;;Adopt procedures
;Reports wether or not v is an ancestor of i or is i.
to-report ancestor? [v i]
if ([who] of v) = ([who] of i) [report true]
if ([parent] of i = -1 or [parent] of i = -2) [report false]
report ancestor? v ([parent] of i)
end
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;DFS Algorithm by Jay Modi with a change by jmv
;It does not always work (there might not be a constraint between parent-child)
;but we "fix" this by adding a constraint between all parent-childs (they are all random graphs anyway ;-)
to send-parent-message
let parents 0
set parents filter [? < who] dfs-neighbors
;show (word "Parents" parents)
ifelse (empty? parents) [
set parent -1 ;the root
][
if (dfs-change) [ ;jmv added dfs-change variable
set parent max parents
send-message parent (filter [? < who] dfs-neighbors)
]
]
end
to handle-dfs-message
set dfs-change false
;show (word "Coada de " message-queue)
if (not empty? message-queue)[
if (not empty? filter [not member? ? dfs-neighbors] (first message-queue))[
set dfs-change true
set dfs-neighbors remove-duplicates sentence dfs-neighbors (first message-queue)
]
set message-queue butfirst message-queue]
end
to set-dfs-tree
let child 0
let nm 0
ask-concurrent nodes [
set dfs-neighbors neighbors-list
set parent -2
set children []
set message-queue []
set dfs-change true
send-parent-message
]
while [any? nodes with [not empty? message-queue]][
ask-concurrent nodes [
handle-dfs-message
send-parent-message
]
]
;ugly hack: add an edge between any parent-child that does not have one
ask nodes [
if (parent != -1 and (not member? parent neighbors-list))[
make-link who parent
set neighbors-list lput parent neighbors-list
set nm who
ask turtle parent [set neighbors-list lput nm neighbors-list ]
show (word "Added extra edge " who " - " parent)
]
]
;sets the parent-agent and children
ask nodes [
if (parent != -1) [
set parent-agent (turtle parent)
set child who
ask turtle parent [ set children fput child children ]
]
]
;sets children-agent and descendant-neigbors
ask nodes [
set children-agent (nodes with [member? who ([children] of myself)])
set-descendant-neighbors
]
end
;;;Tree utility functions
;report true if id is a descendant of node
to-report is-descendant? [node id]
if (member? id ([children] of (turtle node))) [
report true]
if (not empty? ([children] of (turtle node)))[
report reduce [?1 or ?2] map [is-descendant? ? id] ([children] of (turtle node))
]
report false
end
to set-descendant-neighbors
set descendant-neighbors []
foreach neighbors-list [
if (is-descendant? who ?) [
set descendant-neighbors lput ? descendant-neighbors
]
]
end
;vertice procedures
to send-message [receiver msg]
if (show-messages) [show (word "sendto " receiver "-" msg)]
;set [message-queue] of (turtle receiver) lput msg ([message-queue] of (turtle receiver))
ask turtle receiver[ set message-queue lput msg message-queue ]
;set [messages-received] of (turtle receiver) [messages-received] of (turtle receiver) + 1
ask turtle receiver [ set messages-received messages-received + 1]
end
to send-priority-message [receiver msg]
if (show-messages) [show (word "sendto " receiver "-" msg)]
ask turtle receiver [ set message-queue fput msg message-queue ]
end
;delta
;The local-cost is the total number of neighbors with color of d
to-report local-cost [d]
let cost 0
set cost 0
foreach neighbors-list [
if ((item ? current-context != -1) and item ? current-context = d)[
set cost cost + 1
]
]
report cost
end
;LB(d) from the paper.
to-report LBd [d]
let bound 0
set bound local-cost d
foreach children [
set bound bound + get-map-value lbounds d ?
]
report bound
end
;UB(d) from The paper.
to-report UBd [d]
let bound 0
set bound local-cost d
foreach children [
set bound bound + get-map-value ubounds d ?
]
report bound
end
to-report UBmin
let minarg 0
let minval 0
let val 0
set minval 99
foreach domain [
set val UBd ?
if (val < minval)[
set minval val
set minarg ?
]
]
report list minarg minval
end
to-report UB
report item 1 UBmin
end
to-report UBarg
report first UBmin
end
to-report LBmin
let minarg 0
let minval 0
let val 0
set minval 99
foreach domain [
set val LBd ?
if (val < minval)[
set minval val
set minarg ?
]
]
report list minarg minval
end
to-report LB
report item 1 LBmin
end
to-report LBarg
report first LBmin
end
to initialize
let d 0
let xl 0
set threshold 0
set current-context make-context
set last-threshold-message make-list num-nodes []
foreach domain [
set d ?
foreach children [
set xl ?
set lbounds set-map-value lbounds d xl 0
set ubounds set-map-value ubounds d xl 99
set t set-map-value t d xl 0
set context set-map-value context d xl make-context
]
]
backtrack
;instead of doing backtrack, I just send the messages. This way we make sure they go out even if the color does not change.
; foreach descendant-neighbors [
; send-message ? (list "value" who color)
; ]
; if (parent != -1) [
; send-message parent (list "cost" who current-context LB UB)
; ]
end
to handle-message
let msg 0
let mt 0
let SenderC_Cost 0
if (dead) [stop]
if (not empty? message-queue)[
set msg first message-queue
set mt first msg
if (mt = "cycle") [stop]
set message-queue butfirst message-queue
set messages-handled messages-handled + 1
set SenderC_Cost last msg
if SenderC_Cost > AgentC_Cost
[
set AgentC_Cost SenderC_Cost
]
if (mt = "threshold")[
handle-threshold msg
stop]
if (mt = "terminate")[
handle-terminate msg
stop]
if (mt = "value")[
handle-value msg
stop]
if (mt = "cost")[
handle-cost msg
stop]
show (word "ERROR: Bad Message " mt)
]
end
to handle-threshold [msg]
if (show-messages) [show (word "handle-threshold " msg)]
if (compatible? (item 2 msg) current-context)[
set threshold item 1 msg
maintain-threshold-invariant
set need-to-backtrack true
]
end
to handle-terminate [msg]
if (show-messages) [show (word "handle-terminate " msg)]
set terminate true
set current-context (item 1 msg)
set need-to-backtrack true
end
to handle-value [msg]
let d 0
if (show-messages) [show (word "handle-value " msg)]
if (not terminate)[
set current-context add-to-context current-context (item 1 msg) (item 2 msg)
foreach domain [
set d ?
foreach children [
if (not compatible? (get-map-value context d ?) current-context) [
set lbounds set-map-value lbounds d ? 0
set t set-map-value t d ? 0
set ubounds set-map-value ubounds d ? 99
set context set-map-value context d ? make-context
]
]
]
maintain-threshold-invariant
set need-to-backtrack true
]
end
to handle-cost [msg]
let d 0
let xk 0
let dprime 0
let msg-context 0
let i 0
if (show-messages) [show (word "handle-cost " msg)]
set msg-context (item 2 msg)
set d (item who msg-context)
set msg-context remove-from-context msg-context who
if (not terminate)[
foreach (filter [not member? ? neighbors-list] (agents-in-context msg-context))[
set current-context (add-to-context current-context ? (item ? msg-context))
]
foreach domain [
set dprime ?
foreach children [
if (not compatible? (get-map-value context dprime ?) current-context)[
set lbounds set-map-value lbounds dprime ? 0
set t set-map-value t dprime ? 0
set ubounds set-map-value ubounds dprime ? 99
set context set-map-value context dprime ? make-context
]
]
]
]
set xk (item 1 msg)
if (d != -1 and compatible? msg-context current-context)[ ;jmv added d!=1
set lbounds set-map-value lbounds d xk (item 3 msg)
set ubounds set-map-value ubounds d xk (item 4 msg)
set context set-map-value context d xk msg-context
maintain-child-threshold-invariant
maintain-threshold-invariant
]
set need-to-backtrack true
end
to backtrack
let old-color 0
let the-UB 0
set the-UB UB
set old-color color
; if (show-messages) [show "backtrack"]
ifelse (threshold = the-UB) [
set color UBarg
][
if (LBd color > threshold) [
set color LBarg
]
]
; if (old-color != color)[ ;Added by jmv--not part of the published Adopt
foreach descendant-neighbors [
send-message ? (list "value" who color AgentC_Cost)
; ]
]
maintain-allocation-invariant
if (threshold = the-UB) and (terminate or parent = -1) [
foreach children [
send-message ? (list "terminate" (add-my-value-to-context current-context) AgentC_Cost)
]
set dead true
set terminate true
stop
]
if (parent != -1) [
send-message parent (list "cost" who current-context LB the-UB AgentC_Cost)
]
end
to maintain-threshold-invariant
if (threshold < LB)[
set threshold LB
]
if (threshold > UB)[
set threshold UB
]
end
to maintain-allocation-invariant
let sum-of-t 0
let chosen-child 0
let last-sent 0
set sum-of-t sum map [get-map-value t color ?] children
while [threshold > local-cost color + sum-of-t][
set chosen-child one-of (children-agent with [get-map-value ([ubounds] of myself) ([color] of myself) who > get-map-value ([t] of myself) ([color] of myself) who])
set t set-map-value t color ([who] of chosen-child) (1 + get-map-value t color ([who] of chosen-child))
set sum-of-t sum map [get-map-value t color ?] children
]
set sum-of-t sum map [get-map-value t color ?] children
while [threshold < local-cost color + sum-of-t][
set chosen-child one-of children-agent with [get-map-value ([t] of myself) ([color] of myself) who > get-map-value ([lbounds] of myself) ([color] of myself) who]
set t set-map-value t color ([who] of chosen-child) (get-map-value t color ([who] of chosen-child) - 1)
set sum-of-t sum map [get-map-value t color ?] children
]
foreach children [
set last-sent item ? last-threshold-message ;last thresold message sent to this agent
; if (empty? last-sent or first last-sent != (get-map-value t color ?) or (not lists-equal? current-context (item 1 last-sent)))[ ;jmv added. Only send if msg different from previous one
send-message ? (list "threshold" (get-map-value t color ?) current-context AgentC_Cost)
; set last-threshold-message replace-item ? last-threshold-message list (get-map-value t color ?) current-context
; ]
]
end
to maintain-child-threshold-invariant
let d 0
foreach domain [
set d ?
foreach children [
while [get-map-value lbounds d ? > get-map-value t d ?][
set t set-map-value t d ? (get-map-value t d ? + 1)
]
]
]
foreach domain [
set d ?
foreach children [
while [get-map-value t d ? > get-map-value ubounds d ?][
set t set-map-value t d ? (get-map-value t d ? - 1)
]
]
]
end