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