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