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