1# -*- tcl -*-
2# ### ### ### ######### ######### #########
3## Terminal packages - string -> action mappings
4## (menu objects). For use with 'receive listen'.
5## In essence a DFA with tree structure.
6
7# ### ### ### ######### ######### #########
8## Requirements
9
10package require snit
11package require textutil::repeat
12package require textutil::tabify
13package require term::ansi::send
14package require term::receive::bind
15package require term::ansi::code::ctrl
16
17namespace eval ::term::receive::menu {}
18
19# ### ### ### ######### ######### #########
20
21snit::type ::term::interact::menu {
22
23    option -in          -default stdin
24    option -out         -default stdout
25    option -column      -default 0
26    option -line        -default 0
27    option -height      -default 25
28    option -actions     -default {}
29    option -hilitleft   -default 0
30    option -hilitright  -default end
31    option -framed      -default 0 -readonly 1
32
33    # ### ### ### ######### ######### #########
34    ##
35
36    constructor {dict args} {
37	$self configurelist $args
38	Save $dict
39
40	install bind using ::term::receive::bind \
41	    ${selfns}::bind $options(-actions)
42
43	$bind map [cd::cu] [mymethod Up]
44	$bind map [cd::cd] [mymethod Down]
45	$bind map \n       [mymethod Select]
46	#$bind default [mymethod DEF]
47
48	return
49    }
50
51    # ### ### ### ######### ######### #########
52    ##
53
54    method interact {} {
55	Show
56	$bind listen   $options(-in)
57	vwait [myvar done]
58	$bind unlisten $options(-in)
59	return $map($done)
60    }
61
62    method done  {} {set done $at ; return}
63    method clear {} {Clear        ; return}
64
65    # ### ### ### ######### ######### #########
66    ##
67
68    component bind
69
70    # ### ### ### ######### ######### #########
71    ##
72
73    variable map -array {}
74    variable header
75    variable labels
76    variable footer
77    variable empty
78
79    proc Save {dict} {
80	upvar 1 header header labels labels footer footer
81	upvar 1 empty empty at at map map top top
82	upvar 1 options(-height) height
83
84	set max 0
85	foreach {l code} $dict {
86	    if {[set len [string length $l]] > $max} {set max $len}
87	}
88
89	set header [cd::groptim [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]]
90	set footer [cd::groptim [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc]]
91
92	set labels {}
93	set at 0
94	foreach {l code} $dict {
95	    set map($at) $code
96	    lappend labels ${l}[textutil::repeat::strRepeat " " [expr {$max-[string length $l]}]]
97	    incr at
98	}
99
100	set h $height
101	if {$h > [llength $labels]} {set h [llength $labels]}
102
103	set eline "  [textutil::repeat::strRepeat {  } $max]"
104	set empty $eline
105	for {set i 0} {$i <= $h} {incr i} {
106	    append empty \n$eline
107	}
108
109	set at  0
110	set top 0
111	return
112    }
113
114    variable top  0
115    variable at   0
116    variable done .
117
118    proc Show {} {
119	upvar 1 header header labels labels footer footer at at
120	upvar 1 options(-in)     in  options(-column) col top top
121	upvar 1 options(-out)    out options(-line)   row
122	upvar 1 options(-height) height options(-framed) framed
123	upvar 1 options(-hilitleft)  left
124	upvar 1 options(-hilitright) right
125
126	set bot [expr {$top + $height - 1}]
127	set fr  [expr {$framed ? [cd::vl] : { }}]
128
129	set text $header\n
130	set i $top
131	foreach l [lrange $labels $top $bot] {
132	    append text $fr
133	    if {$i != $at} {
134		append text $l
135	    } else {
136		append text [string replace $l $left $right \
137			[cd::sda_revers][string range $l $left $right][cd::sda_reset]]
138	    }
139	    append text $fr \n
140	    incr i
141	}
142	append text $footer
143
144	vt::wrch $out [cd::showat $row $col $text]
145	return
146    }
147
148    proc Clear {} {
149	upvar 1 empty         empty options(-column) col
150	upvar 1 options(-out) out   options(-line)   row
151
152	vt::wrch $out [cd::showat $row $col $empty]
153	return
154    }
155
156    # ### ### ### ######### ######### #########
157    ##
158
159    method Up {str} {
160	if {$at == 0} return
161	incr at -1
162	if {$at < $top} {incr top -1}
163	Show
164	return
165    }
166
167    method Down {str} {
168	upvar 0 options(-height) height
169	if {$at == ([llength $labels]-1)} return
170	incr at
171	set bot [expr {$top + $height - 1}]
172	if {$at > $bot} {incr top}
173	Show
174	return
175    }
176
177    method Select {str} {
178	$self done
179	return
180    }
181
182    method DEF {str} {
183	puts stderr "($str)"
184	exit
185    }
186
187    ##
188    # ### ### ### ######### ######### #########
189}
190
191# ### ### ### ######### ######### #########
192## Ready
193
194namespace eval ::term::interact::menu {
195    term::ansi::code::ctrl::import cd
196    term::ansi::send::import       vt
197}
198
199package provide term::interact::menu 0.1
200
201##
202# ### ### ### ######### ######### #########
203