1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
2-- All rights reserved.
3--
4-- Redistribution and use in source and binary forms, with or without
5-- modification, are permitted provided that the following conditions are
6-- met:
7--
8--     - Redistributions of source code must retain the above copyright
9--       notice, this list of conditions and the following disclaimer.
10--
11--     - Redistributions in binary form must reproduce the above copyright
12--       notice, this list of conditions and the following disclaimer in
13--       the documentation and/or other materials provided with the
14--       distribution.
15--
16--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
17--       names of its contributors may be used to endorse or promote products
18--       derived from this software without specific prior written permission.
19--
20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31
32)package "BOOT"
33
34$historyDisplayWidth := 120
35$newline := char 10
36
37downlink page ==
38  htInitPage('"Bridge",nil)
39  htSayList(['"\replacepage{", page, '"}"])
40  htShowPage()
41
42dbNonEmptyPattern pattern ==
43  null pattern => '"*"
44  pattern := STRINGIMAGE pattern
45  #pattern > 0 => pattern
46  '"*"
47
48htSystemVariables() == main where
49  main ==
50    not $fullScreenSysVars => htSetVars()
51    classlevel := $UserLevel
52    $levels : local := '(compiler development interpreter)
53    $heading  : local := nil
54    while classlevel ~= first $levels repeat $levels := rest $levels
55    table := NREVERSE fn($setOptions,nil,true)
56    htInitPage('"System Variables",nil)
57    htSay '"\beginmenu"
58    lastHeading := nil
59    for [heading,name,message,.,key,variable,options,func] in table repeat
60      htSay('"\newline\item ")
61      if heading = lastHeading then htSay '"\tab{8}" else
62        htSayList([heading, '"\tab{8}"])
63        lastHeading := heading
64      htSayList(['"{\em ", name, "}\tab{22}", message])
65      htSay('"\tab{80}")
66      key = 'FUNCTION =>
67         null options => htMakePage [['bcLinks,['"reset",'"",func,nil]]]
68         [msg,class,var,valuesOrFunction,:.] := first options  --skip first message
69         functionTail(name,class,var,valuesOrFunction)
70         for option in rest options repeat
71           option is ['break,:.] => 'skip
72           [msg,class,var,valuesOrFunction,:.] := option
73           htSayList(['"\newline\tab{22}", msg,'"\tab{80}"])
74           functionTail(name,class,var,valuesOrFunction)
75      val := eval variable
76      displayOptions(name,key,variable,val,options)
77    htSay '"\endmenu"
78    htShowPage()
79  functionTail(name,class,var,valuesOrFunction) ==
80    val := eval var
81    atom valuesOrFunction =>
82      htMakePage '((domainConditions (isDomain STR (String))))
83      htMakePage [['bcLinks,['"reset",'"",'htSetSystemVariableKind,[var,name,nil]]]]
84      htMakePage [['bcStrings,[30,STRINGIMAGE val,name,valuesOrFunction]]]
85    displayOptions(name,class,var,val,valuesOrFunction)
86  displayOptions(name,class,variable,val,options) ==
87    class = 'INTEGER =>
88      htMakePage [['bcLispLinks,[[['text,options.0,'"-",options.1 or '""]],'"",'htSetSystemVariableKind,[variable,name,'PARSE_-INTEGER]]]]
89      htMakePage '((domainConditions (isDomain INT (Integer))))
90      htMakePage  [['bcStrings,[5,STRINGIMAGE val,name,'INT]]]
91    class = 'STRING =>
92      htSayList ['"{\em ", val, '"}\space{1}"]
93    for x in options repeat
94      val = x or val = true and x = 'on or null val and x = 'off =>
95        htSayList ['"{\em ", x, '"}\space{1}"]
96      htMakePage [['bcLispLinks,[x,'" ",'htSetSystemVariable,[variable,x]]]]
97  fn(t,al,firstTime) ==
98    atom t => al
99    if firstTime then $heading := opOf first t
100    fn(rest t,gn(first t,al),firstTime)
101  gn(t,al) ==
102    [.,.,class,key,.,options,:.] := t
103    not MEMQ(class,$levels) => al
104    key = 'LITERALS or key = 'INTEGER or key = 'STRING => [[$heading,:t],:al]
105    key = 'TREE => fn(options,al,false)
106    key = 'FUNCTION => [[$heading,:t],:al]
107    systemError key
108
109htSetSystemVariableKind(htPage,[variable,name,fun]) ==
110  value := htpLabelInputString(htPage,name)
111  if STRINGP value and fun then value := FUNCALL(fun,value)
112--SCM::what to do???  if not FIXP value then userError ???
113  SET(variable,value)
114  htSystemVariables ()
115
116htSetSystemVariable(htPage,[name,value]) ==
117  value :=
118    value = 'on => true
119    value = 'off => nil
120    value
121  SET(name,value)
122  htSystemVariables ()
123
124htGloss(pattern) == htGlossPage(nil,dbNonEmptyPattern pattern or '"*",true)
125
126htGlossPage(htPage,pattern,tryAgain?) ==
127  $wildCard: local := char '_*
128  pattern = '"*" => downlink 'GlossaryPage
129  filter := pmTransFilter pattern
130  grepForm := mkGrepPattern(filter,'none)
131  $key: local := 'none
132  results := applyGrep(grepForm,'gloss)
133  --pathname := STRCONC('"/tmp/",PNAME resultFile,'".text.", getEnv '"SPADNUM")
134  --instream := MAKE_INSTREAM(pathname)
135  defstream := MAKE_INSTREAM(STRCONC(getEnv '"FRICAS",
136                                     '"/algebra/glossdef.text"))
137  lines := gatherGlossLines(results,defstream)
138  -- OBEY STRCONC('"rm -f ", pathname)
139  --PROBE_-FILE(pathname) and DELETE_-FILE(pathname)
140  --SHUT instream
141  heading :=
142    pattern = '"" => '"Glossary"
143    null lines => ['"No glossary items match {\em ",pattern,'"}"]
144    ['"Glossary items matching {\em ",pattern,'"}"]
145  null lines =>
146    tryAgain? and #pattern > 0 =>
147      (pattern.(k := MAXINDEX(pattern))) = char 's =>
148        htGlossPage(htPage,SUBSTRING(pattern,0,k),true)
149      UPPER_-CASE_-P pattern.0 =>
150        htGlossPage(htPage,DOWNCASE pattern,false)
151      errorPage(htPage,['"Sorry",nil,['"\centerline{",:heading,'"}"]])
152    errorPage(htPage,['"Sorry",nil,['"\centerline{",:heading,'"}"]])
153  htInitPageNoScroll(nil,heading)
154  htSay('"\beginscroll\beginmenu")
155  for line in lines repeat
156    tick := charPosition($tick,line,1)
157    htSayList(['"\item{\em \menuitemstyle{}}\tab{0}{\em ",
158               escapeString SUBSTRING(line,0,tick),'"} ",
159               SUBSTRING(line,tick + 1,nil)])
160  htSay '"\endmenu "
161  htSay '"\endscroll\newline "
162  htMakePage [['bcLinks,['"Search",'"",'htGlossSearch,nil]]]
163  htSay '" for glossary entry matching "
164  htMakePage [['bcStrings, [24,'"*",'filter,'EM]]]
165  htShowPageNoScroll()
166
167gatherGlossLines(results,defstream) ==
168  acc := nil
169  for keyline in results repeat
170    --keyline := read_line instream
171    n := charPosition($tick,keyline,0)
172    keyAndTick := SUBSTRING(keyline,0,n + 1)
173    byteAddress := string2Integer SUBSTRING(keyline,n + 1,nil)
174    FILE_-POSITION(defstream,byteAddress)
175    line := read_line defstream
176    k := charPosition($tick,line,1)
177    pointer := SUBSTRING(line,0,k)
178    def := SUBSTRING(line,k + 1,nil)
179    xtralines := nil
180    while not EOFP defstream and (x := read_line defstream) and
181      (j := charPosition($tick,x,1)) and (nextPointer := SUBSTRING(x,0,j))
182        and (nextPointer = pointer) repeat
183          xtralines := [SUBSTRING(x,j + 1,nil),:xtralines]
184    acc := [STRCONC(keyAndTick,def, "STRCONC"/NREVERSE xtralines),:acc]
185  REVERSE acc
186
187htGlossSearch(htPage,junk) ==  htGloss htpLabelInputString(htPage,'filter)
188
189htGreekSearch(filter) ==
190  ss := dbNonEmptyPattern filter
191  s := pmTransFilter ss
192  s is ['error,:.] => bcErrorPage s
193  not s => errorPage(nil,[['"Missing search string"],nil,
194    '"\vspace{2}\centerline{To select one of the greek letters:}\newline ",
195      '"\centerline{{\em first} enter a search key into the input area}\newline ",
196        '"\centerline{{\em then } move the mouse cursor to the work {\em search} and click}"])
197  filter := patternCheck s
198  names := '(alpha beta gamma delta epsilon zeta eta theta iota kappa lambda mu nu pi)
199  for x in names repeat
200    superMatch?(filter,PNAME x) => matches := [x,:matches]
201    nonmatches := [x,:nonmatches]
202  matches    := NREVERSE matches
203  nonmatches := NREVERSE nonmatches
204  htInitPage('"Greek Names",nil)
205  null matches =>
206    htInitPage(['"Greek names matching search string {\em ",ss,'"}"],nil)
207    htSay("\vspace{2}\centerline{Sorry, but no greek letters match your search string}\centerline{{\em ",ss,"}}\centerline{Click on the up-arrow to try again}")
208    htShowPage()
209  htInitPage(['"Greek letters matching search string {\em ",ss,'"}"],nil)
210  if nonmatches
211    then htSayList([
212       '"The greek letters that {\em match} your search string {\em ",
213       ss, '"}:"])
214    else htSay('"Your search string {\em ",ss,"} matches all of the greek letters:")
215  htSay('"{\em \table{")
216  for x in matches repeat htSayList(['"{", x, '"}"])
217  htSay('"}}\vspace{1}")
218  if nonmatches then
219    htSay('"The greek letters that {\em do not match} your search string:{\em \table{")
220    for x in nonmatches repeat htSayList(['"{", x, '"}"])
221    htSay('"}}")
222  htShowPage()
223
224htTextSearch(filter) ==
225  s := pmTransFilter dbNonEmptyPattern filter
226  s is ['error,:.] => bcErrorPage s
227  not s => errorPage(nil,[['"Missing search string"],nil,
228    '"\vspace{2}\centerline{To select one of the lines of text:}\newline ",
229      '"\centerline{{\em first} enter a search key into the input area}\newline ",
230        '"\centerline{{\em then } move the mouse cursor to the work {\em search} and click}"])
231  filter := s
232  lines := ['"{{\em Fruit flies} *like* a {\em banana and califlower ears.}}",
233            '"{{\em Sneak Sears Silas with Savings Snatch}}"]
234  for x in lines repeat
235    superMatch?(filter,x) => matches := [x,:matches]
236    nonmatches := [x,:nonmatches]
237  matches    := NREVERSE matches
238  nonmatches := NREVERSE nonmatches
239  htInitPage('"Text Matches",nil)
240  null matches =>
241    htInitPage(['"Lines matching search string {\em ",s,'"}"],nil)
242    htSay("\vspace{2}\centerline{Sorry, but no lines match your search string}\centerline{{\em ",s,"}}\centerline{Click on the up-arrow to try again}")
243    htShowPage()
244  htInitPage(['"Lines matching search string {\em ",s,'"}"],nil)
245  if nonmatches
246    then htSayList([
247           '"The lines that {\em match} your search string {\em ",
248           s, '"}:"])
249    else htSay('"Your search string {\em ",s,"} matches both lines:")
250  htSay('"{\em \table{")
251  for x in matches repeat htSayList(['"{", x, '"}"])
252  htSay('"}}\vspace{1}")
253  if nonmatches then
254    htSay('"The line that {\em does not match} your search string:{\em \table{")
255    for x in nonmatches repeat htSayList(['"{", x, '"}"])
256    htSay('"}}")
257  htShowPage()
258
259mkUnixPattern s ==
260  u := mkUpDownPattern s
261  starPositions := REVERSE [i for i in 1..(-1 + MAXINDEX u) | u.i = $wild]
262  for i in starPositions repeat
263    u := STRCONC(SUBSTRING(u,0,i),'".*",SUBSTRING(u,i + 1,nil))
264  if u.0 ~= $wild then u := STRCONC('"[^a-zA-Z]",u)
265                  else u := SUBSTRING(u,1,nil)
266  if u.(k := MAXINDEX u) ~= $wild then u := STRCONC(u,'"[^a-zA-Z]")
267                                  else u := SUBSTRING(u,0,k)
268  u
269