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