1# -*- tcl -*-
2
3package require Tk
4package require cache::async
5package require struct::set
6
7namespace eval ::city {
8
9    proc block {n} { variable part ; return [expr {$n * $part}] }
10
11    variable tessel 64
12    variable part   [expr {$tessel/8}]
13    variable cstart [block 2]
14    variable cend   [block 6]
15    variable rstart [block 3]
16    variable rend   [block 5]
17
18    variable parcel [image create photo -height $part -width $part]
19    $parcel put black -to 0 0 $part $part
20
21    variable tilecache [cache::async tc ::city::Gen]
22
23    variable lego  {}
24    variable neigh ; array set neigh {} ; # name,dir -> list(name)
25    variable map   ; array set map   {} ; # name -> (type flags)
26    variable grid  ; array set grid  {} ; # at -> name
27}
28
29proc ::city::tile {} {
30    variable tessel
31    return  $tessel
32}
33
34proc ::city::grid {__ at donecmd} {
35    Tile get [Randomize $at] [list ::city::ToGrid $at $donecmd --]
36    return
37}
38proc ::city::ToGrid {at donecmd -- what key args} {
39    # Route the cache result retrieved by name to the grid cell the
40    # original request came from.
41    #puts "\tToGrid ($at) '$donecmd' $what ($key) <$args>"
42    if {[catch {
43	uplevel #0 [eval [linsert $args 0 linsert $donecmd end $what $at]]
44    }]} { puts $::errorInfo }
45}
46
47proc ::city::Randomize {at} {
48    variable grid
49    set p [Possibilities $at]
50    if {[llength $p] == 1} {
51	set res [lindex $p 0]
52    } else {
53	set res [lindex $p [Rand [llength $p]]]
54    }
55    #puts "($at) = $p"
56    set grid($at) $res
57    return $res
58}
59
60proc ::city::Rand {n} {
61    # 0...n-1
62    # (0,1) -> (0,n)
63    expr {int(rand()*$n)}
64}
65
66proc ::city::Possibilities {at} {
67    variable lego
68    variable grid
69    foreach {y x} $at break
70
71    set l [list [expr {$x - 1}] $y]
72    set r [list [expr {$x + 1}] $y]
73    set u [list $x [expr {$y - 1}]]
74    set d [list $x [expr {$y - 1}]]
75
76    set allowed $lego
77    Cut $l r allowed
78    Cut $r l allowed
79    Cut $u d allowed
80    Cut $d u allowed
81
82    return $allowed
83}
84
85proc ::city::Cut {at dir v} {
86    variable grid
87    variable neigh
88    upvar 1 $v allowed
89    foreach {y x} $at break
90    if {![info exists grid($at)]} return
91    set allowed [struct::set intersect $allowed $neigh($grid($at),$dir)]
92    return
93}
94
95proc ::city::Tile {__ name donecmd} {
96    variable tilecache
97    #puts "__ $name ($donecmd)"
98    $tilecache get $name $donecmd
99    return
100}
101
102proc ::city::Gen {__ name donecmd} {
103    variable tessel
104    variable cstart
105    variable cend
106    variable rstart
107    variable rend
108    variable parcel
109    variable map
110
111    #puts "\tGENERATE $name ($donecmd)"
112
113    foreach {olx orx oux odx ilx irx iux idx cx} $map($name) break
114    set tile [image create photo -height $tessel -width $tessel]
115    $tile put white -to 0 0 $tessel $tessel
116    #puts ([join $map($name) {)(}])|$olx|$orx|$oux|$odx|$ilx|$irx|$iux|$idx|$cx|
117    if {$cx}  { $tile copy $parcel -to $rstart $rstart $rend   $rend   } ; # center
118
119    if {$olx} { $tile copy $parcel -to 0       $rstart $cstart $rend   } ; # ou left
120    if {$orx} { $tile copy $parcel -to $cend   $rstart $tessel $rend   } ; # ou right
121    if {$oux} { $tile copy $parcel -to $rstart 0       $rend   $cstart } ; # ou up
122    if {$odx} { $tile copy $parcel -to $rstart $cend   $rend   $tessel } ; # ou down
123
124    if {$ilx} { $tile copy $parcel -to $cstart $rstart $rstart $rend   } ; # in left
125    if {$irx} { $tile copy $parcel -to $rend   $rstart $cend   $rend   } ; # in right
126    if {$iux} { $tile copy $parcel -to $rstart $cstart $rend   $rstart } ; # in up
127    if {$idx} { $tile copy $parcel -to $rstart $cend   $rend   $cend   } ; # in down
128
129    if 0 {
130	set label $olx$orx$oux$odx/$ilx$irx$iux$idx/$cx
131	#set label [string range $name 0 3]/[string range $name 4 7]/[string index $name 8]
132	label .l$name -image $tile -bd 2 -relief sunken
133	pack .l$name -side left
134	tooltip::tooltip .l$name $label
135    }
136
137    #puts "run ([linsert $donecmd end set $name $tile])"
138    uplevel #0 [linsert $donecmd end set $name $tile]
139    return
140}
141
142proc ::city::Name {olx orx oux odx ilx irx iux idx cx} {
143    #set name "$olx$orx$oux$odx$ilx$irx$iux$idx$cx"
144    set name ""
145    if {$cx}  { append name c } ; # center
146    if {$olx} { append name l } ; # left
147    if {$ilx} { append name - } ; # left
148    if {$orx} { append name r } ; # right
149    if {$irx} { append name _ } ; # right
150    if {$oux} { append name u } ; # up
151    if {$iux} { append name = } ; # up
152    if {$odx} { append name d } ; # down
153    if {$idx} { append name % } ; # down
154    if {$name eq ""} { set name empty }
155    #puts $name\ ...
156    return $name
157}
158
159proc ::city::Init {} {
160    variable lego
161    variable neigh
162    variable map
163
164    foreach olx {0 1} {
165	foreach orx {0 1} {
166	    foreach oux {0 1} {
167		foreach odx {0 1} {
168		    foreach ilx {0 1} {
169			foreach irx {0 1} {
170			    foreach iux {0 1} {
171				foreach idx {0 1} {
172				    foreach cx {0 1} {
173					# inner not allowed without center
174					if {!$cx && $ilx} continue
175					if {!$cx && $irx} continue
176					if {!$cx && $iux} continue
177					if {!$cx && $idx} continue
178
179					#if {!$olx && $ilx} continue
180					#if {!$orx && $irx} continue
181					#if {!$oux && $iux} continue
182					#if {!$odx && $idx} continue
183
184					set n [Name $olx $orx $oux $odx $ilx $irx $iux $idx $cx]
185					set map($n) [list $olx $orx $oux $odx $ilx $irx $iux $idx $cx]
186					lappend bins(l$olx) $n
187					lappend bins(r$orx) $n
188					lappend bins(u$oux) $n
189					lappend bins(d$odx) $n
190					lappend lego $n
191				    }
192				}
193			    }
194			}
195		    }
196		}
197	    }
198	}
199    }
200
201    #puts /[llength $lego]
202
203    # Now compute which tiles can be neighbours of what others, for
204    # all four sides.
205
206    foreach t $bins(d0) { foreach n $bins(u0) { lappend neigh($t,d) $n } }
207    foreach t $bins(d1) { foreach n $bins(u1) { lappend neigh($t,d) $n } }
208    foreach t $bins(l0) { foreach n $bins(r0) { lappend neigh($t,l) $n } }
209    foreach t $bins(l1) { foreach n $bins(r1) { lappend neigh($t,l) $n } }
210    foreach t $bins(u0) { foreach n $bins(d0) { lappend neigh($t,u) $n } }
211    foreach t $bins(u1) { foreach n $bins(d1) { lappend neigh($t,u) $n } }
212    foreach t $bins(r0) { foreach n $bins(l0) { lappend neigh($t,r) $n } }
213    foreach t $bins(r1) { foreach n $bins(l1) { lappend neigh($t,r) $n } }
214
215    foreach k [array names neigh] { set neigh($k) [lsort -unique $neigh($k)] }
216    return
217}
218
219::city::Init
220#exit
221