1## -*- tcl -*- 2## (C) 2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> 3## BSD Licensed 4# # ## ### ##### ######## ############# ###################### 5 6# 7# Database of named directions, for use in the diagram controller. 8# 9# Directions are identified by name and each has a set of attributes, 10# each identified by name, with associated value. The attributes are 11# not typed. 12# 13# Standard attributes are 'angle' and 'oppposite', the first providing 14# the angle of the direction, in degrees (0-360, 0 == right/east, 90 15# == up/north), and the second naming the complentary direction going 16# into the opposite direction (+/- 180 degrees). 17# 18# The eight directions (octants) of the compass rose are predefined, 19# standard. 20# 21# Beyond the directions the system also manages 'aliases', 22# i.e. alternate/secondary names for the primary directions. 23# 24# All names are handled case-insensitive! 25# 26 27## 28# # ## ### ##### ######## ############# ###################### 29## Requisites 30 31package require Tcl 8.5 ; # Want the nice things it brings (dicts, {*}, etc.) 32package require snit ; # Object framework. 33 34# # ## ### ##### ######## ############# ###################### 35## Implementation 36 37snit::type ::diagram::direction { 38 39 # # ## ### ##### ######## ############# ###################### 40 ## Public API :: Extending the database 41 42 method {new direction} {name args} { 43 set thename [string tolower $name] 44 # Argument validation. 45 if {[info exists myinfo($thename)] || 46 [info exists myalias($thename)]} { 47 return -code error "direction already known" 48 } elseif {[llength $args] % 2 == 1} { 49 return -code error "Expected a dictionary, got \"$args\"" 50 } elseif {![dict exists $args angle]} { 51 return -code error "Standard attribute 'angle' is missing" 52 } elseif {![dict exists $args opposite]} { 53 return -code error "Standard attribute 'opposite' is missing" 54 } 55 # Note: Can't check the value of opposite, a direction, for 56 # existence, because then we are unable to define the pairs. 57 58 # Should either check the angle, or auto-reduce to the proper 59 # interval. 60 61 set myinfo($thename) $args 62 return 63 } 64 65 method {new alias} {name primary} { 66 set thename [string tolower $name] 67 set theprimary [string tolower $primary] 68 # Argument validation. 69 if {[info exists myalias($thename)]} { 70 return -code error "alias already known" 71 } elseif {![info exists myalias($theprimary)] && 72 ![info exists myinfo($theprimary)]} { 73 return -code error "existing direction expected, not known" 74 } 75 # (*a) Resolve alias to alias in favor of the underlying 76 # primary => Short lookup, no iteration required. 77 if {[info exists myalias($theprimary)]} { 78 set theprimary $myalias($theprimary) 79 } 80 # And remember the mapping. 81 set mydb($thename) $theprimary 82 return 83 } 84 85 # # ## ### ##### ######## ############# ###################### 86 ## Public API :: Validate directions, either as explict angle, or named. 87 ## and return it normalized (angle reduced to 88 ## interval, primary name of any alias). 89 90 method validate {direction} { 91 if {[Norm $direction angle]} { return $angle } 92 set d $direction 93 # Only one alias lookup necessary, see (*a) in 'new alias'. 94 if {[info exists myalias($d)]} { set d $myalias($d) } 95 if {[info exists myinfo($d)]} { return $d } 96 return -code error "Expected direction, got \"$direction\"" 97 } 98 99 method is {d} { 100 if {[Norm $d angle]} { return 1 } 101 # Only one alias lookup necessary, see (*a) in 'new alias'. 102 if {[info exists myalias($d)]} { set d $myalias($d) } 103 return [info exists myinfo($d)] 104 } 105 106 method isStrict {d} { 107 # Only one alias lookup necessary, see (*a) in 'new alias'. 108 if {[info exists myalias($d)]} { set d $myalias($d) } 109 return [info exists myinfo($d)] 110 } 111 112 method map {corners c} { 113 if {[dict exists $corners $c]} { 114 return $c 115 } elseif {[$self is $c]} { 116 set new [$self validate $c] 117 if {$new ne $c} { 118 return $new 119 } 120 } 121 122 # Find nearest corner by angle. 123 set angle [$self get $c angle] 124 set delta Inf 125 set min {} 126 foreach d [dict keys $corners] { 127 if {![$self isStrict $d]} continue 128 if {[catch { 129 set da [$self get $d angle] 130 }]} continue 131 set dda [expr {abs($da - $angle)}] 132 if {$dda >= $delta} continue 133 set delta $dda 134 set min $d 135 } 136 if {$min ne $c} { 137 return $min 138 } 139 return $c 140 } 141 142 # # ## ### ##### ######## ############# ###################### 143 ## Public API :: Retrieve directional attributes (all, or 144 ## specific). Accepts angles as well, and uses 145 ## nearest named direction. 146 147 method get {direction {detail {}}} { 148 if {[Norm $direction angle]} { 149 set d [$self FindByAngle $angle] 150 } elseif {[info exists myalias($direction)]} { 151 set d $myalias($direction) 152 } else { 153 set d $direction 154 } 155 if {[info exists myinfo($d)]} { 156 if {[llength [info level 0]] == 7} { 157 return [dict get $myinfo($d) $detail] 158 } else { 159 return $myinfo($d) 160 } 161 } 162 return -code error "Expected direction, got \"$direction\"" 163 } 164 165 # # ## ### ##### ######## ############# ###################### 166 167 proc Norm {angle varname} { 168 if {![string is double -strict $angle]} { return 0 } 169 while {$angle < 0} { set angle [expr {$angle + 360}] } 170 while {$angle > 360} { set angle [expr {$angle - 360}] } 171 upvar 1 $varname normalized 172 set normalized $angle 173 return 1 174 } 175 176 method FindByAngle {angle} { 177 # Find nearest named angle. 178 set name {} 179 set delta 720 180 foreach k [array names myinfo] { 181 if {![dict exists $myinfo($k) angle]} continue 182 set a [dict get $myinfo($k) angle] 183 if {$a eq {}} continue 184 set d [expr {abs($a-$angle)}] 185 if {$d < $delta} { 186 set delta $d 187 set name $k 188 } 189 } 190 return $name 191 } 192 193 # # ## ### ##### ######## ############# ###################### 194 ## Instance data, database tables as arrays, keyed by direction 195 ## and alias names. 196 197 # Standard directions, the eight sections of the compass rose, 198 # with angles and opposite, complementary direction. 199 # 200 # 135 90 45 201 # nw n ne 202 # \|/ 203 # 180 w -*- e 0 204 # /|\. 205 # sw s se 206 # 225 270 315 207 208 variable myinfo -array { 209 east {angle 0 opposite west } 210 northeast {angle 45 opposite southwest} 211 north {angle 90 opposite south } 212 northwest {angle 135 opposite southeast} 213 west {angle 180 opposite east } 214 southwest {angle 225 opposite northeast} 215 south {angle 270 opposite north } 216 southeast {angle 315 opposite northwest} 217 218 center {} 219 } 220 221 # Predefined aliases for the standard directions 222 # Cardinal and intermediate directions. 223 # Names and appropriate unicode symbols. 224 variable myalias -array { 225 c center 226 227 w west left west \u2190 west 228 s south down south \u2191 north 229 e east right east \u2192 east 230 n north up north \u2193 south 231 232 t north top north r east 233 b south bottom south l west 234 bot south 235 236 nw northwest up-left northwest \u2196 northwest 237 ne northeast up-right northeast \u2197 northeast 238 se southeast down-right southeast \u2198 southeast 239 sw southwest down-left southwest \u2199 southwest 240 241 upleft northwest leftup northwest 242 upright northeast rightup northeast 243 downright southeast rightdown southeast 244 downleft southwest leftdown southwest 245 } 246 247 ## 248 # # ## ### ##### ######## ############# ###################### 249} 250 251# # ## ### ##### ######## ############# ###################### 252## Ready 253 254package provide diagram::direction 1 255