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
33-- HyperTeX Utilities for generating basic Command pages
34
35)package "BOOT"
36
37$bcParseOnly := true
38
39-- List of issued hypertex lines
40$htLineList := nil
41
42-- pointer to the page we are currently defining
43$curPage := nil
44
45-- List of currently active window named
46$activePageList := nil
47
48htpDestroyPage(pageName) ==
49  pageName in $activePageList =>
50    SET(pageName, nil)
51    $activePageList := NREMOVE($activePageList, pageName)
52
53htpName htPage ==
54-- GENSYM whose value is the page
55  ELT(htPage, 0)
56
57htpSetName(htPage, val) ==
58  SETELT(htPage, 0, val)
59
60htpDomainConditions htPage ==
61-- List of Domain conditions
62  ELT(htPage, 1)
63
64htpSetDomainConditions(htPage, val) ==
65  SETELT(htPage, 1, val)
66
67htpDomainVariableAlist htPage ==
68-- alist of pattern variables and conditions
69  ELT(htPage, 2)
70
71htpSetDomainVariableAlist(htPage, val) ==
72  SETELT(htPage, 2, val)
73
74htpDomainPvarSubstList htPage ==
75-- alist of user pattern variables to system vars
76  ELT(htPage, 3)
77
78htpSetDomainPvarSubstList(htPage, val) ==
79  SETELT(htPage, 3, val)
80
81htpRadioButtonAlist htPage ==
82-- alist of radio button group names and labels
83  ELT(htPage, 4)
84
85htpButtonValue(htPage, groupName) ==
86  for buttonName in LASSOC(groupName, htpRadioButtonAlist htPage) repeat
87    (stripSpaces htpLabelInputString(htPage, buttonName)) = '"t" =>
88      return buttonName
89
90htpSetRadioButtonAlist(htPage, val) ==
91  SETELT(htPage, 4, val)
92
93htpInputAreaAlist htPage ==
94-- Alist of input-area labels, and default values
95  ELT(htPage, 5)
96
97htpSetInputAreaAlist(htPage, val) ==
98  SETELT(htPage, 5, val)
99
100htpPropertyList htPage ==
101-- Association list of user-defined properties
102  ELT(htPage, 6)
103
104htpProperty(htPage, propName) ==
105  LASSOC(propName, ELT(htPage, 6))
106
107htpSetProperty(htPage, propName, val) ==
108  pair := assoc(propName, ELT(htPage, 6))
109  pair => RPLACD(pair, val)
110  SETELT(htPage, 6, [[propName, :val], :ELT(htPage, 6)])
111
112htpLabelInputString(htPage, label) ==
113-- value user typed as input string on page
114  props := LASSOC(label, htpInputAreaAlist htPage)
115  props and STRINGP (s := ELT(props,0)) =>
116    s = '"" => s
117    trimString s
118  nil
119
120htpLabelFilteredInputString(htPage, label) ==
121-- value user typed as input string on page
122  props := LASSOC(label, htpInputAreaAlist htPage)
123  props =>
124    #props > 5 and ELT(props, 6) =>
125      FUNCALL(SYMBOL_-FUNCTION ELT(props, 6), ELT(props, 0))
126    replacePercentByDollar ELT(props, 0)
127  nil
128
129replacePercentByDollar s == fn(s,0,MAXINDEX s) where
130  fn(s,i,n) ==
131    i > n => '""
132    (m := charPosition(char "%",s,i)) > n => SUBSTRING(s,i,nil)
133    STRCONC(SUBSTRING(s,i,m - i),'"$",fn(s,m + 1,n))
134
135htpLabelSpadValue(htPage, label) ==
136-- Scratchpad value of parsed and evaled inputString, as (type . value)
137  props := LASSOC(label, htpInputAreaAlist htPage)
138  props => ELT(props, 1)
139  nil
140
141htpSetLabelSpadValue(htPage, label, val) ==
142-- value user typed as input string on page
143  props := LASSOC(label, htpInputAreaAlist htPage)
144  props => SETELT(props, 1, val)
145  nil
146
147htpLabelErrorMsg(htPage, label) ==
148-- error message associated with input area
149  props := LASSOC(label, htpInputAreaAlist htPage)
150  props => ELT(props, 2)
151  nil
152
153htpSetLabelErrorMsg(htPage, label, val) ==
154-- error message associated with input area
155  props := LASSOC(label, htpInputAreaAlist htPage)
156  props => SETELT(props, 2, val)
157  nil
158
159htpLabelType(htPage, label) ==
160-- either 'string or 'button
161  props := LASSOC(label, htpInputAreaAlist htPage)
162  props => ELT(props, 3)
163  nil
164
165htpLabelDefault(htPage, label) ==
166-- default value for the input area
167  msg := htpLabelInputString(htPage, label) =>
168    msg = '"t" => 1
169    msg = '"nil" => 0
170    msg
171  props := LASSOC(label, htpInputAreaAlist htPage)
172  props =>
173    ELT(props, 4)
174  nil
175
176
177htpLabelSpadType(htPage, label) ==
178-- pattern variable for target domain for input area
179  props := LASSOC(label, htpInputAreaAlist htPage)
180  props => ELT(props, 5)
181  nil
182
183htpLabelFilter(htPage, label) ==
184-- string to string mapping applied to input area strings before parsing
185  props := LASSOC(label, htpInputAreaAlist htPage)
186  props => ELT(props, 6)
187  nil
188
189htpPageDescription htPage ==
190-- a list of all the commands issued to create the basic-command page
191  ELT(htPage, 7)
192
193htpSetPageDescription(htPage, pageDescription) ==
194  SETELT(htPage, 7, pageDescription)
195
196iht line ==
197-- issue a single hyperteTeX line, or a group of lines
198  $newPage => nil
199  PAIRP line =>
200    $htLineList := NCONC(nreverse mapStringize COPY_-LIST line, $htLineList)
201  $htLineList := [basicStringize line, :$htLineList]
202
203bcIssueHt line ==
204  PAIRP line => htMakePage1 line
205  iht line
206
207mapStringize l ==
208  ATOM l => l
209  RPLACA(l, basicStringize first l)
210  RPLACD(l, mapStringize rest l)
211  l
212
213basicStringize s ==
214  STRINGP s =>
215    s = '"\$"      => '"\%"
216    s = '"{\em $}" => '"{\em \%}"
217    s
218  s = '_$ => '"\%"
219  PRINC_-TO_-STRING s
220
221stringize s ==
222  STRINGP s => s
223  PRINC_-TO_-STRING s
224
225
226htQuote s ==
227-- wrap quotes around a piece of hyperTeX
228  iht '"_""
229  iht s
230  iht '"_""
231
232htProcessToggleButtons buttons ==
233  iht '"\newline\indent{5}\beginitems "
234  for [message, info, defaultValue, buttonName] in buttons repeat
235    if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then
236      setUpDefault(buttonName, ['button, defaultValue])
237    iht ['"\item{\em\inputbox[", htpLabelDefault($curPage, buttonName), '"]{",
238         buttonName, '"}{\htbmfile{pick}}{\htbmfile{unpick}}\space{}"]
239    bcIssueHt message
240    iht '"\space{}}"
241    bcIssueHt info
242  iht '"\enditems\indent{0} "
243
244htProcessBcButtons buttons ==
245  for [defaultValue, buttonName] in buttons repeat
246    if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then
247      setUpDefault(buttonName, ['button, defaultValue])
248    k := htpLabelDefault($curPage,buttonName)
249    k = 0 => iht ['"\off{",buttonName,'"}"]
250    k = 1 => iht ['"\on{", buttonName,'"}"]
251    iht ['"\inputbox[", htpLabelDefault($curPage, buttonName), '"]{",
252         buttonName, '"}{\htbmfile{pick}}{\htbmfile{unpick}}"]
253
254bcSadFaces() ==
255  '"\space{1}{\em\htbitmap{error}\htbitmap{error}\htbitmap{error}}"
256
257htLispLinks(links,:option) ==
258  [links,options] := beforeAfter('options,links)
259  indent := LASSOC('indent,options) or 5
260  iht '"\newline\indent{"
261  iht stringize indent
262  iht '"}\beginitems"
263  for [message, info, func, :value] in links repeat
264    iht '"\item["
265    call := (IFCAR option => '"\lispmemolink"; '"\lispdownlink")
266    htMakeButton(call,message, mkCurryFun(func, value))
267    iht ['"]\space{}"]
268    bcIssueHt info
269  iht '"\enditems\indent{0} "
270
271htLispMemoLinks(links) == htLispLinks(links,true)
272
273beforeAfter(x,u) == [[y for [y,:r] in tails u while x ~= y],r]
274
275mkCurryFun(fun, val) ==
276  name := GENTEMP()
277  code :=
278    ['DEFUN, name, '(arg), ['APPLY, MKQ fun, ['CONS, 'arg, MKQ val]]]
279  EVAL code
280  name
281
282htRadioButtons [groupName, :buttons] ==
283  htpSetRadioButtonAlist($curPage, [[groupName, :buttonNames buttons],
284                                    : htpRadioButtonAlist $curPage])
285  boxesName := GENTEMP()
286  iht ['"\newline\indent{5}\radioboxes{", boxesName,
287     '"}{\htbmfile{pick}}{\htbmfile{unpick}}\beginitems "]
288  defaultValue := '"1"
289  for [message, info, buttonName] in buttons repeat
290    if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then
291      setUpDefault(buttonName, ['button, defaultValue])
292      defaultValue := '"0"
293    iht ['"\item{\em\radiobox[", htpLabelDefault($curPage, buttonName), '"]{",
294         buttonName, '"}{",boxesName, '"}\space{}"]
295    bcIssueHt message
296    iht '"\space{}}"
297    bcIssueHt info
298  iht '"\enditems\indent{0} "
299
300htBcRadioButtons [groupName, :buttons] ==
301  htpSetRadioButtonAlist($curPage, [[groupName, :buttonNames buttons],
302                                    : htpRadioButtonAlist $curPage])
303  boxesName := GENTEMP()
304  iht ['"\radioboxes{", boxesName,
305     '"}{\htbmfile{pick}}{\htbmfile{unpick}} "]
306  defaultValue := '"1"
307  for [message, info, buttonName] in buttons repeat
308    if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then
309      setUpDefault(buttonName, ['button, defaultValue])
310      defaultValue := '"0"
311    iht ['"{\em\radiobox[", htpLabelDefault($curPage, buttonName), '"]{",
312         buttonName, '"}{",boxesName, '"}"]
313    bcIssueHt message
314    iht '"\space{}}"
315    bcIssueHt info
316
317buttonNames buttons ==
318  [buttonName for [.,., buttonName] in buttons]
319
320htInputStrings strings ==
321  iht '"\newline\indent{5}\beginitems "
322  for [mess1, mess2, numChars, default, stringName, spadType, :filter]
323   in strings repeat
324    if NULL LASSOC(stringName, htpInputAreaAlist $curPage) then
325      setUpDefault(stringName, ['string, default, spadType, filter])
326    if htpLabelErrorMsg($curPage, stringName) then
327      iht ['"\centerline{{\em ", htpLabelErrorMsg($curPage, stringName), '"}}"]
328
329      mess2 := CONCAT(mess2, bcSadFaces())
330      htpSetLabelErrorMsg($curPage, stringName, nil)
331    iht '"\item "
332    bcIssueHt mess1
333    iht ['"\inputstring{", stringName, '"}{",
334         numChars, '"}{", htpLabelDefault($curPage,stringName), '"} "]
335    bcIssueHt mess2
336  iht '"\enditems\indent{0}\newline "
337
338htProcessDomainConditions condList ==
339  htpSetDomainConditions($curPage, renamePatternVariables condList)
340  htpSetDomainVariableAlist($curPage, computeDomainVariableAlist())
341
342renamePatternVariables condList ==
343  htpSetDomainPvarSubstList($curPage,
344    renamePatternVariables1(condList, nil, $PatternVariableList))
345  substFromAlist(condList, htpDomainPvarSubstList $curPage)
346
347renamePatternVariables1(condList, substList, patVars) ==
348  null condList => substList
349  [cond, :restConds] := condList
350  cond is ['isDomain, pv, pattern] or cond is ['ofCategory, pv, pattern]
351    or cond is ['Satisfies, pv, cond] =>
352      if pv = $EmptyMode then nsubst := substList
353      else nsubst := [[pv, :car patVars], :substList]
354      renamePatternVariables1(restConds, nsubst, rest patVars)
355  substList
356
357substFromAlist(l, substAlist) ==
358  for [pvar, :replace] in substAlist repeat
359    l := substitute(replace, pvar, l)
360  l
361
362computeDomainVariableAlist() ==
363  [[pvar, :pvarCondList pvar] for [., :pvar] in
364    htpDomainPvarSubstList $curPage]
365
366pvarCondList pvar ==
367  nreverse pvarCondList1([pvar], nil, htpDomainConditions $curPage)
368
369pvarCondList1(pvarList, activeConds, condList) ==
370  null condList => activeConds
371  [cond, : restConds] := condList
372  cond is [., pv, pattern] and pv in pvarList =>
373    pvarCondList1(nconc(pvarList, pvarsOfPattern pattern),
374                  [cond, :activeConds], restConds)
375  pvarCondList1(pvarList, activeConds, restConds)
376
377pvarsOfPattern pattern ==
378  NULL LISTP pattern => nil
379  [pvar for pvar in rest pattern | pvar in $PatternVariableList]
380
381htMakeTemplates(templateList, numLabels) ==
382  templateList := [templateParts template for template in templateList]
383  [[substLabel(i, template) for template in templateList]
384    for i in 1..numLabels] where substLabel(i, template) ==
385      PAIRP template =>
386        INTERN CONCAT(first template, PRINC_-TO_-STRING i, rest template)
387      template
388
389templateParts template ==
390  NULL STRINGP template => template
391  i := SEARCH('"%l", template)
392  null i => template
393  [SUBSEQ(template, 0, i), : SUBSEQ(template, i+2)]
394
395htMakeDoneButton(message, func) ==
396  bcHt '"\newline\vspace{1}\centerline{"
397  if message = '"Continue" then
398    bchtMakeButton('"\lispdownlink", "\ContinueBitmap", func)
399  else
400    bchtMakeButton('"\lispdownlink",CONCAT('"\box{", message, '"}"), func)
401  bcHt '"} "
402
403htProcessDoneButton [label , func] ==
404  iht '"\newline\vspace{1}\centerline{"
405
406  if label = '"Continue" then
407    htMakeButton('"\lispdownlink", "\ContinueBitmap", func)
408  else if label = '"Push to enter names" then
409    htMakeButton('"\lispdownlink",'"\ControlBitmap{ClickToSet}", func)
410  else
411    htMakeButton('"\lispdownlink", CONCAT('"\box{", label, '"}"), func)
412
413  iht '"} "
414
415bchtMakeButton(htCommand, message, func) ==
416  bcHt [htCommand, '"{", message,
417       '"}{(|htDoneButton| '|", func, '"| (PROGN "]
418  for [id, ., ., ., type, :.] in htpInputAreaAlist $curPage repeat
419    bcHt ['"(|htpSetLabelInputString| ", htpName $curPage, '"'|", id, '"| "]
420    if type = 'string then
421      bcHt ['"_"\stringvalue{", id, '"}_""]
422    else
423      bcHt ['"_"\boxvalue{", id, '"}_""]
424    bcHt '") "
425  bcHt [htpName $curPage, '"))} "]
426
427htProcessDoitButton [label, command, func] ==
428  fun := mkCurryFun(func, [command])
429  iht '"\newline\vspace{1}\centerline{"
430  htMakeButton('"\lispcommand", CONCAT('"\box{", label, '"}"), fun)
431  iht '"} "
432  iht '"\vspace{2}{Select \  \UpButton{} \  to go back one page.}"
433  iht '"\newline{Select \  \ExitButton{QuitPage} \  to remove this window.}"
434
435htMakeDoitButton(label, command) ==
436  -- use bitmap button if just plain old "Do It"
437  if label = '"Do It" then
438    bcHt '"\newline\vspace{1}\centerline{\lispcommand{\DoItBitmap}{(|doDoitButton| "
439  else
440    bcHt ['"\newline\vspace{1}\centerline{\lispcommand{\box{", label,
441       '"}}{(|doDoitButton| "]
442  bcHt htpName $curPage
443  bcHt ['" _"", htEscapeString command, '"_""]
444  bcHt '")}}"
445
446  bcHt '"\vspace{2}{Select \  \UpButton{} \  to go back one page.}"
447  bcHt '"\newline{Select \  \ExitButton{QuitPage} \  to remove this window.}"
448
449doDoitButton(htPage, command) ==
450  executeInterpreterCommand command
451
452executeInterpreterCommand command ==
453  PRINC command
454  TERPRI()
455  setCurrentLine(command)
456  CATCH('SPAD_READER, parseAndInterpret command)
457--  MRX I'm not sure whether I should call ioHook("startPrompt")/ioHook("endOfPrompt") here
458  princPrompt()
459  FORCE_-OUTPUT()
460
461typeCheckInputAreas htPage ==
462  -- This needs to be severely beefed up
463  inputAlist := nil
464  errorCondition := false
465  for entry in htpInputAreaAlist htPage
466   | entry is [stringName, ., ., ., 'string, ., spadType, filter] repeat
467    condList :=
468      LASSOC(LASSOC(spadType,htpDomainPvarSubstList htPage),
469             htpDomainVariableAlist htPage)
470    string := htpLabelFilteredInputString(htPage, stringName)
471    $bcParseOnly =>
472      null ncParseFromString string =>
473        htpSetLabelErrorMsg(htPage, '"Syntax Error", '"Syntax Error")
474      nil
475    val := checkCondition(htpLabelInputString(htPage, stringName),
476                          string, condList)
477    STRINGP val =>
478      errorCondition := true
479      htpSetLabelErrorMsg(htPage, stringName, val)
480    htpSetLabelSpadValue(htPage, stringName, val)
481  errorCondition
482
483checkCondition(s1, string, condList) ==
484  condList is [['Satisfies, pvar, pred]] =>
485    val := FUNCALL(pred, string)
486    STRINGP val => val
487    ['(String), :wrap s1]
488  condList isnt [['isDomain, pvar, pattern]] =>
489    systemError '"currently invalid domain condition"
490  pattern is '(String) => ['(String), :wrap s1]
491  val := parseAndEval string
492  STRINGP val =>
493    val = '"Syntax Error " => '"Error: Syntax Error "
494    condErrorMsg pattern
495  [type, : data] := val
496  newType := CATCH('SPAD_READER, resolveTM(type, pattern))
497  null newType =>
498    condErrorMsg pattern
499  coerceInt(val, newType)
500
501condErrorMsg type ==
502  typeString := form2String type
503  if PAIRP typeString then typeString := concatenateStringList(typeString)
504  CONCAT('"Error: Could not make your input into a ", typeString)
505
506parseAndEval string ==
507  $InteractiveMode :fluid := true
508  $e:fluid := $InteractiveFrame
509  $QuietCommand:local := true
510  parseAndEval1 string
511
512parseAndEval1 string ==
513  syntaxError := false
514  pform :=
515      v := applyWithOutputToString('ncParseFromString, [string])
516      CAR v => CAR v
517      syntaxError := true
518      CDR v
519  syntaxError =>
520     '"Syntax Error "
521  pform =>
522    val := applyWithOutputToString('processInteractive, [pform, nil])
523    CAR val => CAR val
524    '"Type Analysis Error"
525  nil
526
527-- predefined filter strings
528bracketString string == CONCAT('"[",string,'"]")
529
530quoteString string == CONCAT('"_"", string, '"_"")
531
532$funnyQuote := char 127
533$funnyBacks := char 128
534
535htEscapeString str ==
536  str := SUBSTITUTE($funnyQuote, char '_", str)
537  SUBSTITUTE($funnyBacks, char '_\, str)
538
539unescapeStringsInForm form ==
540  STRINGP form =>
541    str := NSUBSTITUTE(char '_", $funnyQuote, form)
542    NSUBSTITUTE(char '_\, $funnyBacks, str)
543  CONSP form =>
544    unescapeStringsInForm first form
545    unescapeStringsInForm rest form
546    form
547  form
548