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
34htsv() ==
35  startHTPage(50)
36  htSetVars()
37
38htSetVars() ==
39  $path := nil
40  $lastTree := nil
41  if 0 ~= LASTATOM $setOptions then htMarkTree($setOptions,0)
42  htShowSetTree($setOptions)
43
44htShowSetTree(setTree) ==
45  $path := TAKE(- LASTATOM setTree,$path)
46  page := htInitPage(mkSetTitle(),nil)
47  htpSetProperty(page, 'setTree, setTree)
48  links := nil
49  maxWidth1 := maxWidth2 := 0
50  for setData in setTree repeat
51    satisfiesUserLevel setData.setLevel =>
52      okList := [setData,:okList]
53      maxWidth1 := MAX(# PNAME setData.setName,maxWidth1)
54      maxWidth2 := MAX(htShowCount STRINGIMAGE setData.setLabel,maxWidth2)
55  maxWidth1 := MAX(9,maxWidth1)
56  maxWidth2 := MAX(41,maxWidth2)
57  tabset1 := STRINGIMAGE (maxWidth1)
58  tabset2 := STRINGIMAGE (maxWidth2 + maxWidth1 - 1)
59  htSayList(['"\tab{2}\newline Variable\tab{",
60    STRINGIMAGE (maxWidth1 + QUOTIENT(maxWidth2, 3)),
61     '"}Description\tab{",STRINGIMAGE(maxWidth2 + maxWidth1 + 2),
62      '"}Value\newline\beginitems "])
63  for setData in REVERSE okList repeat
64      htSay '"\item"
65      label := STRCONC('"\menuitemstyle{",setData.setName,'"}")
66      links := [label,[['text,'"\tab{",tabset1,'"}",setData.setLabel,'"\tab{",tabset2,'"}{\em ",htShowSetTreeValue setData,'"}"]],
67                'htShowSetPage, setData.setName]
68      htMakePage [['bcLispLinks, links,'options,'(indent . 0)]]
69  htSay '"\enditems"
70  htShowPage()
71
72htShowCount s == --# discounting {\em .. }
73  m := #s
74  m < 8 => m - 1
75  i := 0
76  count := 0
77  while i < m - 7 repeat
78    s.i = char '_{ and  s.(i+1) = char '_\ and s.(i+2) = char 'e
79      and s.(i+3) = char 'm => i := i + 6     --discount {\em }
80    i := i + 1
81    count := count + 1
82  count + (m - i)
83
84htShowSetTreeValue(setData) ==
85  st := setData.setType
86  st = 'FUNCTION => object2String FUNCALL(setData.setVar,"%display%")
87  st = 'INTEGER  => object2String eval setData.setVar
88  st = 'STRING  => object2String eval setData.setVar
89  st = 'LITERALS =>
90    object2String translateTrueFalse2YesNo eval setData.setVar
91  st = 'TREE     => '"..."
92  systemError()
93
94mkSetTitle() == STRCONC('"Command {\em )set ",listOfStrings2String $path,'"}")
95
96listOfStrings2String u ==
97  null u => '""
98  STRCONC(listOfStrings2String rest u,'" ",stringize first u)
99
100htShowSetPage(htPage, branch) ==
101  setTree := htpProperty(htPage, 'setTree)
102  $path := [branch,:TAKE(- LASTATOM setTree,$path)]
103  setData := assoc(branch, setTree)
104  null setData =>
105    systemError('"No Set Data")
106  st := setData.setType
107  st = 'FUNCTION => htShowFunctionPage(htPage, setData)
108  st = 'INTEGER  =>  htShowIntegerPage(htPage,setData)
109  st = 'LITERALS => htShowLiteralsPage(htPage, setData)
110  st = 'TREE     => htShowSetTree(setData.setLeaf)
111
112  st = 'STRING   =>  -- have to add this
113     htSetNotAvailable(htPage,'")set compiler")
114
115  systemError '"Unknown data type"
116
117htShowLiteralsPage(htPage, setData) ==
118  htSetLiterals(htPage,setData.setName,setData.setLabel,
119                setData.setVar,setData.setLeaf,'htSetLiteral)
120
121htSetLiterals(htPage,name,message,variable,values,functionToCall) ==
122  page := htInitPage('"Set Command", htpPropertyList htPage)
123  htpSetProperty(page, 'variable, variable)
124  bcHt ['"\centerline{Set {\em ", name, '"}}\newline"]
125  bcHt ['"{\em Description: } ", message, '"\newline\vspace{1} "]
126  bcHt '"Select one of the following: \newline\tab{3} "
127  links := [[STRCONC('"",STRINGIMAGE opt), '"\newline\tab{3}", functionToCall, opt] for opt in values]
128  htMakePage [['bcLispLinks, :links]]
129  bcHt ["\indent{0}\newline\vspace{1} The current setting is: {\em ",
130        translateTrueFalse2YesNo EVAL variable, '"} "]
131  htShowPage()
132
133htSetLiteral(htPage, val) ==
134  htInitPage('"Set Command", nil)
135  SET(htpProperty(htPage, 'variable), translateYesNo2TrueFalse val)
136  htKill(htPage,val)
137
138htShowIntegerPage(htPage, setData) ==
139  page := htInitPage(mkSetTitle(), htpPropertyList htPage)
140  htpSetProperty(page, 'variable, setData.setVar)
141  bcHt ['"\centerline{Set {\em ", setData.setName, '"}}\newline"]
142  message := setData.setLabel
143  bcHt ['"{\em Description: } ", message, '"\newline\vspace{1} "]
144  [$htInitial,$htFinal] := setData.setLeaf
145  if $htFinal = $htInitial + 1
146    then
147      bcHt '"Enter the integer {\em "
148      bcHt stringize $htInitial
149      bcHt '"} or {\em "
150      bcHt stringize $htFinal
151      bcHt '"}:"
152    else if null $htFinal then
153      bcHt '"Enter an integer greater than {\em "
154      bcHt stringize ($htInitial - 1)
155      bcHt '"}:"
156    else
157      bcHt '"Enter an integer between {\em "
158      bcHt stringize $htInitial
159      bcHt '"} and {\em "
160      bcHt stringize $htFinal
161      bcHt '"}:"
162  htMakePage [
163    '(domainConditions (Satisfies S chkRange)),
164      ['bcStrings,[5,eval setData.setVar,'value,'S]]]
165  htSetvarDoneButton('"Select to Set Value",'htSetInteger)
166  htShowPage()
167
168htSetInteger(htPage) ==
169  htInitPage(mkSetTitle(), nil)
170  val := chkRange htpLabelInputString(htPage,'value)
171  not INTEGERP val =>
172    errorPage(htPage,['"Value Error",nil,'"\vspace{3}\centerline{{\em ",val,'"}}\vspace{2}\newline\centerline{Click on \UpBitmap{} to re-enter value}"])
173  SET(htpProperty(htPage, 'variable), val)
174  htKill(htPage,val)
175
176htShowFunctionPage(htPage,setData) ==
177  fn := setData.setDef => FUNCALL(fn,htPage)
178  htpSetProperty(htPage,'setData,setData)
179  htpSetProperty(htPage,'parts, setData.setLeaf)
180  htShowFunctionPageContinued(htPage)
181
182htShowFunctionPageContinued(htPage) ==
183  parts := htpProperty(htPage,'parts)
184  setData := htpProperty(htPage,'setData)
185  [[phrase,kind,variable,checker,initValue,:.],:restParts] := parts
186  htpSetProperty(htPage, 'variable, variable)
187  htpSetProperty(htPage, 'checker, checker)
188  htpSetProperty(htPage, 'parts, restParts)
189  kind = 'LITERALS => htSetLiterals(htPage,setData.setName,
190                                    phrase,variable,checker,'htFunctionSetLiteral)
191  page := htInitPage(mkSetTitle(), htpPropertyList htPage)
192  bcHt ['"\centerline{Set {\em ", setData.setName, '"}}\newline"]
193  bcHt ['"{\em Description: } ", setData.setLabel, '"\newline\vspace{1} "]
194  currentValue := EVAL variable
195  htMakePage
196    [ ['domainConditions, ['Satisfies,'S,checker]],
197      ['text,:phrase],
198        ['inputStrings,
199          [ '"", '"", 60, currentValue, 'value, 'S]]]
200  htSetvarDoneButton('"Select To Set Value",'htSetFunCommand)
201  htShowPage()
202
203htSetvarDoneButton(message, func) ==
204  bcHt '"\newline\vspace{1}\centerline{"
205
206  if message = '"Select to Set Value" or message = '"Select to Set Values"  then
207    bchtMakeButton('"\lisplink",'"\ControlBitmap{ClickToSet}", func)
208  else
209    bchtMakeButton('"\lisplink",CONCAT('"\fbox{", message, '"}"), func)
210
211  bcHt '"} "
212
213
214htFunctionSetLiteral(htPage, val) ==
215  htInitPage('"Set Command", nil)
216  SET(htpProperty(htPage, 'variable), translateYesNo2TrueFalse val)
217  htSetFunCommandContinue(htPage,val)
218
219htSetFunCommand(htPage) ==
220  variable := htpProperty(htPage,'variable)
221  checker := htpProperty(htPage,'checker)
222  value := htCheck(checker,htpLabelInputString(htPage,'value))
223  SET(variable,value) --kill this later
224  htSetFunCommandContinue(htPage,value)
225
226htSetFunCommandContinue(htPage,value) ==
227  parts := htpProperty(htPage,'parts)
228  continue :=
229    null parts => false
230    parts is [['break,predicate],:restParts] => eval predicate
231    true
232  continue =>
233    htpSetProperty(htPage,'parts,restParts)
234    htShowFunctionPageContinued(htPage)
235  htKill(htPage,value)
236
237htKill(htPage,value) ==
238  htInitPage('"System Command", nil)
239  string := STRCONC('"{\em )set ",listOfStrings2String [value,:$path],'"}")
240  htMakePage [
241     '(text
242        "{Here is the FriCAS system command you could have issued:}"
243            "\vspace{2}\newline\centerline{\tt"),
244      ['text,:string]]
245  htMakePage '((text . "}\vspace{1}\newline\rm"))
246  htSay '"\vspace{2}{Select \  \UpButton{} \  to go back.}"
247  htSay '"\newline{Select \  \ExitButton{QuitPage} \  to remove this window.}"
248  htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing]
249  htShowPage()
250
251htSetNotAvailable(htPage,whatToType) ==
252  page := htInitPage('"Unavailable Set Command", htpPropertyList htPage)
253  htInitPage('"Unavailable System Command", nil)
254  string := STRCONC('"{\em ",whatToType,'"}")
255  htMakePage [
256     '(text "\vspace{1}\newline"
257        "{Sorry, but this system command is not available through HyperDoc. Please directly issue this command in a FriCAS window for more information:}"
258            "\vspace{2}\newline\centerline{\tt"),
259      ['text,:string]]
260  htMakePage '((text . "}\vspace{1}\newline"))
261  htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing]
262  htShowPage()
263
264htDoNothing(htPage,command) == nil
265
266htCheck(checker,value) ==
267  PAIRP checker => htCheckList(checker,parseWord value)
268  FUNCALL(checker,value)
269
270parseWord x ==
271  STRINGP x =>
272    and/[DIGITP x.i for i in 0..MAXINDEX x] => PARSE_-INTEGER x
273    INTERN x
274  x
275
276htCheckList(checker,value) ==
277  if value in '(y ye yes Y YE YES) then value := 'yes
278  if value in '(n no N NO) then value := 'no
279  checker is [n,m] and INTEGERP n =>
280    m = n + 1 =>
281      value in checker => value
282      n
283    null m =>
284      INTEGERP value and value >= n => value
285      n
286    INTEGERP m =>
287      INTEGERP value and value >= n and value <= m => value
288      n
289  value in checker => value
290  first checker
291--  emlist := "STRCONC"/[STRCONC('" {\em ",PNAME x,'"} ") for x in checker]
292--  STRCONC('"Please enter one of: ",emlist)
293
294translateYesNoToTrueFalse x ==
295  x = 'yes => true
296  x = 'no => false
297  x
298
299chkNameList x ==
300  u := bcString2ListWords x
301  parsedNames := [ncParseFromString x for x in u]
302  and/[IDENTP x for x in parsedNames] => parsedNames
303  '"Please enter a list of identifiers separated by blanks"
304
305chkPosInteger s ==
306  (u := parseOnly s) and INTEGERP u and u > 0 => u
307  '"Please enter a positive integer"
308
309chkOutputFileName s ==
310  bcString2WordList s in '(CONSOLE console) => 'console
311  chkDirectory s
312
313chkDirectory s == s
314
315chkNonNegativeInteger s ==
316  (u := ncParseFromString s) and INTEGERP u and u >= 0 => u
317  '"Please enter a non-negative integer"
318
319chkRange s ==
320  (u := ncParseFromString s) and INTEGERP u
321    and u >= $htInitial and (NULL $htFinal or u <= $htFinal)
322      => u
323  null $htFinal =>
324    STRCONC('"Please enter an integer greater than ",stringize ($htInitial - 1))
325  STRCONC('"Please enter an integer between ",stringize $htInitial,'" and ",
326            stringize $htFinal)
327
328chkAllNonNegativeInteger s ==
329  (u := ncParseFromString s) and u in '(a al all A AL ALL) and 'ALL
330    or chkNonNegativeInteger s
331       or '"Please enter {\em all} or a non-negative integer"
332
333htMakePathKey path ==
334  null path => systemError '"path is not set"
335  INTERN fn(PNAME first path,rest path) where
336    fn(a,b) ==
337      null b => a
338      fn(STRCONC(a,'".",PNAME first b),rest b)
339
340htMarkTree(tree,n) ==
341  RPLACD(LASTTAIL tree,n)
342  for branch in tree repeat
343    branch.3 = 'TREE => htMarkTree(branch.5,n + 1)
344
345htSetHistory htPage ==
346  msg := "when the history facility is on (yes), results of computations are saved in memory"
347  data := ['history,msg,'history,'LITERALS,'$HiFiAccess,'(on off yes no)]
348  htShowLiteralsPage(htPage,data)
349
350htSetOutputLibrary htPage ==
351  htSetNotAvailable(htPage,'")set compiler output")
352
353htSetInputLibrary htPage ==
354  htSetNotAvailable(htPage,'")set compiler input")
355
356htSetExpose htPage ==
357  htSetNotAvailable(htPage,'")set expose")
358
359htSetKernelProtect htPage ==
360 htSetNotAvailable(htPage,'")set kernel protect")
361
362htSetKernelWarn htPage ==
363 htSetNotAvailable(htPage,'")set kernel warn")
364
365htSetOutputCharacters htPage ==
366  htSetNotAvailable(htPage,'")set output characters")
367
368htSetLinkerArgs htPage ==
369  htSetNotAvailable(htPage,'")set fortran calling linker")
370
371htSetCache(htPage,:options) ==
372  $path := '(functions cache)
373  htPage := htInitPage(mkSetTitle(),nil)
374  $valueList := nil
375  htMakePage '(
376   (text
377    "Use this system command to cause the FriCAS interpreter to `remember' "
378    "past values of interpreter functions. "
379    "To remember a past value of a function, the interpreter "
380    "sets up a {\em cache} for that function based on argument values. "
381    "When a value is cached for a given argument value, its value is gotten "
382    "from the cache and not recomputed. Caching can often save much "
383    "computing time, particularly with recursive functions or functions that "
384    "are expensive to compute and that are called repeatedly "
385    "with the same argument."
386    "\vspace{1}\newline ")
387   (domainConditions (Satisfies S chkNameList))
388   (text
389      "Enter below a list of interpreter functions you would like specially cached. "
390      "Use the name {\em all} to give a default setting for all "
391      "interpreter functions. "
392      "\vspace{1}\newline "
393      "Enter {\em all} or a list of names (separate names by blanks):")
394   (inputStrings ("" "" 60 "all" names S))
395   (doneButton "Push to enter names" htCacheAddChoice))
396  htShowPage()
397
398htCacheAddChoice htPage ==
399  names := bcString2WordList htpLabelInputString(htPage,'names)
400  $valueList := [listOfStrings2String names,:$valueList]
401  null names => htCacheAddQuery()
402  null rest names => htCacheOne names
403  page := htInitPage(mkSetTitle(),nil)
404  htpSetProperty(page,'names,names)
405  htMakePage '(
406    (domainConditions (Satisfies ALLPI chkAllPositiveInteger))
407    (text
408      "For each function, enter below a {\em cache length}, a positive integer. "
409      "This number tells how many past values will "
410      "be cached. "
411      "A cache length of {\em 0} means the function won't be cached. "
412      "To cache all past values, "
413      "enter {\em all}."
414      "\vspace{1}\newline "
415      "For each function name, enter {\em all} or a positive integer:"))
416  for i in 1.. for name in names repeat htMakePage [
417      ['inputStrings,
418        [STRCONC('"Function {\em ",name,'"} will cache"),
419          '"values",5,10,htMakeLabel('"c",i),'ALLPI]]]
420  htSetvarDoneButton('"Select to Set Values",'htCacheSet)
421  htShowPage()
422
423htMakeLabel(prefix,i) == INTERN STRCONC(prefix,stringize i)
424
425htCacheSet htPage ==
426  names := htpProperty(htPage,'names)
427  for i in 1.. for name in names repeat
428    num := chkAllNonNegativeInteger
429             htpLabelInputString(htPage,htMakeLabel('"c",i))
430    $cacheAlist := ADDASSOC(INTERN name,num,$cacheAlist)
431  if (n := LASSOC('all,$cacheAlist)) then
432    $cacheCount := n
433    $cacheAlist := deleteAssoc('all,$cacheAlist)
434  htInitPage('"Cache Summary",nil)
435  bcHt '"In general, interpreter functions "
436  bcHt
437    $cacheCount = 0 => "will {\em not} be cached."
438    bcHt '"cache "
439    htAllOrNum $cacheCount
440    '"} values."
441  bcHt '"\vspace{1}\newline "
442  if $cacheAlist then
443--    bcHt '" However, \indent{3}"
444    for [name,:val] in $cacheAlist | val ~= $cacheCount repeat
445      bcHt '"\newline function {\em "
446      bcHt stringize name
447      bcHt '"} will cache "
448      htAllOrNum val
449      bcHt '"} values"
450  htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing]
451  htShowPage()
452
453htAllOrNum val == bcHt
454  val = 'all => '"{\em all"
455  val = 0 => '"{\em no"
456  STRCONC('"the last {\em ",stringize val)
457
458htCacheOne names ==
459  page := htInitPage(mkSetTitle(),nil)
460  htpSetProperty(page,'names,names)
461  htMakePage '(
462    (domainConditions (Satisfies ALLPI chkAllPositiveInteger))
463    (text
464      "Enter below a {\em cache length}, a positive integer. "
465      "This number tells how many past values will "
466      "be cached. To cache all past values, "
467      "enter {\em all}."
468      "\vspace{1}\newline ")
469    (inputStrings
470      ("Enter {\em all} or a positive integer:"
471       "" 5 10 c1 ALLPI)))
472  htSetvarDoneButton('"Select to Set Value",'htCacheSet)
473  htShowPage()
474