diff --git a/changelog b/changelog index c07cc93..ddea8b0 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090905 tpd src/axiom-website/patches.html 20090905.03.tpd.patch +20090905 tpd src/interp/Makefile move ht-util.boot to ht-util.lisp +20090905 tpd src/interp/ht-util.lisp added, rewritten from ht-util.boot +20090905 tpd src/interp/ht-util.boot removed, rewritten to ht-util.lisp 20090905 tpd src/axiom-website/patches.html 20090905.02.tpd.patch 20090905 tpd src/interp/ax.lisp fix typo 20090905 tpd src/axiom-website/patches.html 20090905.01.tpd.patch diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 14c13e1..b074076 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1992,5 +1992,7 @@ src/interp/wi1.lisp rewrite from boot to lisp
src/interp/wi2.lisp rewrite from boot to lisp
20090905.02.tpd.patch src/interp/ax.lisp fix typo
+20090905.03.tpd.patch +src/interp/ht-util.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 0408445..000de15 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -3247,37 +3247,31 @@ ${MID}/bc-matrix.lisp: ${IN}/bc-matrix.lisp.pamphlet \subsection{ht-util.boot} <>= ${AUTO}/ht-util.${O}: ${OUT}/ht-util.${O} - @ echo 438 making ${AUTO}/ht-util.${O} from ${OUT}/ht-util.${O} + @ echo 422 making ${AUTO}/ht-util.${O} from ${OUT}/ht-util.${O} @ cp ${OUT}/ht-util.${O} ${AUTO} @ +\subsection{ht-util.lisp} <>= -${OUT}/ht-util.${O}: ${MID}/ht-util.clisp - @ echo 439 making ${OUT}/ht-util.${O} from ${MID}/ht-util.clisp - @ (cd ${MID} ; \ +${OUT}/ht-util.${O}: ${MID}/ht-util.lisp + @ echo 136 making ${OUT}/ht-util.${O} from ${MID}/ht-util.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/ht-util.clisp"' \ - ':output-file "${OUT}/ht-util.${O}") (${BYE}))' | ${DEPSYS} ; \ + echo '(progn (compile-file "${MID}/ht-util.lisp"' \ + ':output-file "${OUT}/ht-util.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/ht-util.clisp"' \ - ':output-file "${OUT}/ht-util.${O}") (${BYE}))' | ${DEPSYS} \ + echo '(progn (compile-file "${MID}/ht-util.lisp"' \ + ':output-file "${OUT}/ht-util.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/ht-util.clisp: ${IN}/ht-util.boot.pamphlet - @ echo 440 making ${MID}/ht-util.clisp from ${IN}/ht-util.boot.pamphlet +<>= +${MID}/ht-util.lisp: ${IN}/ht-util.lisp.pamphlet + @ echo 137 making ${MID}/ht-util.lisp from \ + ${IN}/ht-util.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/ht-util.boot.pamphlet >ht-util.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "ht-util.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "ht-util.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm ht-util.boot ) + ${TANGLE} ${IN}/ht-util.lisp.pamphlet >ht-util.lisp ) @ @@ -3330,37 +3324,29 @@ ${MID}/htcheck.lisp: ${IN}/htcheck.lisp.pamphlet \subsection{ax.boot} <>= ${AUTO}/ax.${O}: ${OUT}/ax.${O} - @ echo 461 making ${AUTO}/ax.${O} from ${OUT}/ax.${O} + @ echo 465 making ${AUTO}/ax.${O} from ${OUT}/ax.${O} @ cp ${OUT}/ax.${O} ${AUTO} @ <>= -${OUT}/ax.${O}: ${MID}/ax.clisp - @ echo 462 making ${OUT}/ax.${O} from ${MID}/ax.clisp - @ (cd ${MID} ; \ +${OUT}/ax.${O}: ${MID}/ax.lisp + @ echo 136 making ${OUT}/ax.${O} from ${MID}/ax.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/ax.clisp"' \ - ':output-file "${OUT}/ax.${O}") (${BYE}))' | ${DEPSYS} ; \ + echo '(progn (compile-file "${MID}/ax.lisp"' \ + ':output-file "${OUT}/ax.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/ax.clisp"' \ - ':output-file "${OUT}/ax.${O}") (${BYE}))' | ${DEPSYS} \ + echo '(progn (compile-file "${MID}/ax.lisp"' \ + ':output-file "${OUT}/ax.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/ax.clisp: ${IN}/ax.boot.pamphlet - @ echo 463 making ${MID}/ax.clisp from ${IN}/ax.boot.pamphlet +<>= +${MID}/ax.lisp: ${IN}/ax.lisp.pamphlet + @ echo 137 making ${MID}/ax.lisp from ${IN}/ax.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/ax.boot.pamphlet >ax.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "ax.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "ax.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm ax.boot ) + ${TANGLE} ${IN}/ax.lisp.pamphlet >ax.lisp ) @ @@ -4295,7 +4281,7 @@ clean: <> <> -<> +<> <> <> @@ -4420,7 +4406,7 @@ clean: <> <> -<> +<> <> <> diff --git a/src/interp/ht-util.boot.pamphlet b/src/interp/ht-util.boot.pamphlet deleted file mode 100644 index def38cd..0000000 --- a/src/interp/ht-util.boot.pamphlet +++ /dev/null @@ -1,1446 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp ht-util.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - --- HyperTeX Utilities for generating basic Command pages ---)package "BOOT" - -$bcParseOnly := true - --- List of issued hypertex lines -$htLineList := nil - --- pointer to the page we are currently defining -$curPage := nil - --- List of currently active window named -$activePageList := nil - -htpDestroyPage(pageName) == - pageName in $activePageList => - SET(pageName, nil) - $activePageList := NREMOVE($activePageList, pageName) - -htpName htPage == --- GENSYM whose value is the page - ELT(htPage, 0) - -htpSetName(htPage, val) == - SETELT(htPage, 0, val) - -htpDomainConditions htPage == --- List of Domain conditions - ELT(htPage, 1) - -htpSetDomainConditions(htPage, val) == - SETELT(htPage, 1, val) - -htpDomainVariableAlist htPage == --- alist of pattern variables and conditions - ELT(htPage, 2) - -htpSetDomainVariableAlist(htPage, val) == - SETELT(htPage, 2, val) - -htpDomainPvarSubstList htPage == --- alist of user pattern variables to system vars - ELT(htPage, 3) - -htpSetDomainPvarSubstList(htPage, val) == - SETELT(htPage, 3, val) - -htpRadioButtonAlist htPage == --- alist of radio button group names and labels - ELT(htPage, 4) - -htpButtonValue(htPage, groupName) == - for buttonName in LASSOC(groupName, htpRadioButtonAlist htPage) repeat - (stripSpaces htpLabelInputString(htPage, buttonName)) = '"t" => - return buttonName - -htpSetRadioButtonAlist(htPage, val) == - SETELT(htPage, 4, val) - -htpInputAreaAlist htPage == --- Alist of input-area labels, and default values - ELT(htPage, 5) - -htpSetInputAreaAlist(htPage, val) == - SETELT(htPage, 5, val) - -htpAddInputAreaProp(htPage, label, prop) == - SETELT(htPage, 5, [[label, nil, nil, nil, :prop], :ELT(htPage, 5)]) - -htpPropertyList htPage == --- Association list of user-defined properties - ELT(htPage, 6) - -htpProperty(htPage, propName) == - LASSOC(propName, ELT(htPage, 6)) - -htpSetProperty(htPage, propName, val) == - pair := ASSOC(propName, ELT(htPage, 6)) - pair => RPLACD(pair, val) - SETELT(htPage, 6, [[propName, :val], :ELT(htPage, 6)]) - -htpLabelInputString(htPage, label) == --- value user typed as input string on page - props := LASSOC(label, htpInputAreaAlist htPage) - props and STRINGP (s := ELT(props,0)) => - s = '"" => s - trimString s - nil - -htpLabelFilteredInputString(htPage, label) == --- value user typed as input string on page - props := LASSOC(label, htpInputAreaAlist htPage) - props => - #props > 5 and ELT(props, 6) => - FUNCALL(SYMBOL_-FUNCTION ELT(props, 6), ELT(props, 0)) - replacePercentByDollar ELT(props, 0) - nil - -replacePercentByDollar s == fn(s,0,MAXINDEX s) where - fn(s,i,n) == - i > n => '"" - (m := charPosition(char "%",s,i)) > n => SUBSTRING(s,i,nil) - STRCONC(SUBSTRING(s,i,m - i),'"$",fn(s,m + 1,n)) - -htpSetLabelInputString(htPage, label, val) == -------------------> OBSELETE --- value user typed as input string on page - props := LASSOC(label, htpInputAreaAlist htPage) - props => SETELT(props, 0, STRINGIMAGE val) - nil - -htpLabelSpadValue(htPage, label) == --- Scratchpad value of parsed and evaled inputString, as (type . value) - props := LASSOC(label, htpInputAreaAlist htPage) - props => ELT(props, 1) - nil - -htpSetLabelSpadValue(htPage, label, val) == --- value user typed as input string on page - props := LASSOC(label, htpInputAreaAlist htPage) - props => SETELT(props, 1, val) - nil - -htpLabelErrorMsg(htPage, label) == --- error message associated with input area - props := LASSOC(label, htpInputAreaAlist htPage) - props => ELT(props, 2) - nil - -htpSetLabelErrorMsg(htPage, label, val) == --- error message associated with input area - props := LASSOC(label, htpInputAreaAlist htPage) - props => SETELT(props, 2, val) - nil - -htpLabelType(htPage, label) == --- either 'string or 'button - props := LASSOC(label, htpInputAreaAlist htPage) - props => ELT(props, 3) - nil - -htpLabelDefault(htPage, label) == --- default value for the input area - msg := htpLabelInputString(htPage, label) => - msg = '"t" => 1 - msg = '"nil" => 0 - msg - props := LASSOC(label, htpInputAreaAlist htPage) - props => - ELT(props, 4) - nil - - -htpLabelSpadType(htPage, label) == --- pattern variable for target domain for input area - props := LASSOC(label, htpInputAreaAlist htPage) - props => ELT(props, 5) - nil - -htpLabelFilter(htPage, label) == --- string to string mapping applied to input area strings before parsing - props := LASSOC(label, htpInputAreaAlist htPage) - props => ELT(props, 6) - nil - -htpPageDescription htPage == --- a list of all the commands issued to create the basic-command page - ELT(htPage, 7) - -htpSetPageDescription(htPage, pageDescription) == - SETELT(htPage, 7, pageDescription) - -htpAddToPageDescription(htPage, pageDescrip) == --------------> OBSELETE <----------- - SETELT(htPage, 7, nconc(nreverse COPY_-LIST pageDescrip, ELT(htPage, 7))) - -iht line == --- issue a single hyperteTeX line, or a group of lines - $newPage => nil - PAIRP line => - $htLineList := NCONC(nreverse mapStringize COPY_-LIST line, $htLineList) - $htLineList := [basicStringize line, :$htLineList] - -bcHt line == ---line = '"\##1" => harharhar() - iht line - PAIRP line => - if $newPage then htpAddToPageDescription($curPage, [['text, :line]]) - if $newPage then htpAddToPageDescription($curPage, [['text, line]]) - -bcIssueHt line == - PAIRP line => htMakePage1 line - iht line - -mapStringize l == - ATOM l => l - RPLACA(l, basicStringize CAR l) - RPLACD(l, mapStringize CDR l) - l - -basicStringize s == - STRINGP s => - s = '"\$" => '"\%" - s = '"{\em $}" => '"{\em \%}" - s - s = '_$ => '"\%" - PRINC_-TO_-STRING s - -stringize s == - STRINGP s => s - PRINC_-TO_-STRING s - -htInitPage(title, propList) == -----------------------------> OBSELETE---cannot return $curPage --- start defining a hyperTeX page - htInitPageNoScroll(propList, title) - htSayStandard '"\beginscroll " - $curPage - - ---htInitPageNoHeading(propList) == ------------------------> replaced by htInitPageNoScroll --- start defining a hyperTeX page --- $curPage := htpMakeEmptyPage(propList) --- if $saturn then $saturnPage := htpMakeEmptyPage(propList) --- $newPage := true --- $htLineList := nil --- $curPage - -htAddHeading(title) == -------------------------> OBSELETE - htNewPage title - $curPage - -htShowPage() == --- show the page which has been computed - htSayStandard '"\endscroll" - htShowPageNoScroll() - -htShowPageNoScroll() == -------------------------> OBSELETE --- show the page which has been computed - htSayStandard '"\autobuttons" - htpSetPageDescription($curPage, nreverse htpPageDescription $curPage) - $newPage := false - $htLineList := nil - htMakePage htpPageDescription $curPage - line := APPLY(function CONCAT, nreverse $htLineList) - issueHT line - endHTPage() - -htMakePage itemList == -------------------------> OBSELETE --- make a page given the description in itemList - if $newPage then htpAddToPageDescription($curPage, itemList) - htMakePage1 itemList - -htMakePage1 itemList == --- make a page given the description in itemList - for [itemType, :items] in itemList repeat - itemType = 'text => iht items - itemType = 'lispLinks => htLispLinks items - itemType = 'lispmemoLinks => htLispMemoLinks items - itemType = 'bcLinks => htBcLinks items ---> - itemType = 'bcLinksNS => htBcLinks(items,true) - itemType = 'bcLispLinks => htBcLispLinks items ---> - itemType = 'radioButtons => htRadioButtons items - itemType = 'bcRadioButtons => htBcRadioButtons items - itemType = 'inputStrings => htInputStrings items - itemType = 'domainConditions => htProcessDomainConditions items - itemType = 'bcStrings => htProcessBcStrings items - itemType = 'toggleButtons => htProcessToggleButtons items - itemType = 'bcButtons => htProcessBcButtons items - itemType = 'doneButton => htProcessDoneButton items - itemType = 'doitButton => htProcessDoitButton items - systemError ['"unknown itemType", itemType] - -htMakeErrorPage htPage == -------------------> OBSELETE - $newPage := false - $htLineList := nil - $curPage := htPage - htMakePage htpPageDescription htPage - line := APPLY(function CONCAT, nreverse $htLineList) - issueHT line - endHTPage() - -htQuote s == --- wrap quotes around a piece of hyperTeX - iht '"_"" - iht s - iht '"_"" - -htProcessToggleButtons buttons == - iht '"\newline\indent{5}\beginitems " - for [message, info, defaultValue, buttonName] in buttons repeat - if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then - setUpDefault(buttonName, ['button, defaultValue]) - iht ['"\item{\em\inputbox[", htpLabelDefault($curPage, buttonName), '"]{", - buttonName, '"}{\htbmfile{pick}}{\htbmfile{unpick}}\space{}"] - bcIssueHt message - iht '"\space{}}" - bcIssueHt info - iht '"\enditems\indent{0} " - -htProcessBcButtons buttons == - for [defaultValue, buttonName] in buttons repeat - if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then - setUpDefault(buttonName, ['button, defaultValue]) - k := htpLabelDefault($curPage,buttonName) - k = 0 => iht ['"\off{",buttonName,'"}"] - k = 1 => iht ['"\on{", buttonName,'"}"] - iht ['"\inputbox[", htpLabelDefault($curPage, buttonName), '"]{", - buttonName, '"}{\htbmfile{pick}}{\htbmfile{unpick}}"] - -htProcessBcStrings strings == ----------------------> OBSELETE <------------------------ - for [numChars, default, stringName, spadType, :filter] in strings repeat - mess2 := '"" - if NULL LASSOC(stringName, htpInputAreaAlist $curPage) then - setUpDefault(stringName, ['string, default, spadType, filter]) - if htpLabelErrorMsg($curPage, stringName) then - iht ['"\centerline{{\em ", htpLabelErrorMsg($curPage, stringName), '"}}"] - mess2 := CONCAT(mess2, bcSadFaces()) - htpSetLabelErrorMsg($curPage, stringName, nil) - iht ['"\inputstring{", stringName, '"}{", - numChars, '"}{", htpLabelDefault($curPage,stringName), '"} ", mess2] - -bcSadFaces() == - '"\space{1}{\em\htbitmap{error}\htbitmap{error}\htbitmap{error}}" - -htLispLinks(links,:option) == - [links,options] := beforeAfter('options,links) - indent := LASSOC('indent,options) or 5 - iht '"\newline\indent{" - iht stringize indent - iht '"}\beginitems" - for [message, info, func, :value] in links repeat - iht '"\item[" - call := (IFCAR option => '"\lispmemolink"; '"\lispdownlink") - htMakeButton(call,message, mkCurryFun(func, value)) - iht ['"]\space{}"] - bcIssueHt info - iht '"\enditems\indent{0} " - -htLispMemoLinks(links) == htLispLinks(links,true) - -htBcLinks(links,:options) == --------------------------> OBSELETE - skipStateInfo? := IFCAR options - [links,options] := beforeAfter('options,links) - for [message, info, func, :value] in links repeat - htMakeButton('"\lispdownlink",message, - mkCurryFun(func, value),skipStateInfo?) - bcIssueHt info - -htBcLispLinks links == --------------------------> OBSELETE - [links,options] := beforeAfter('options,links) - for [message, info, func, :value] in links repeat - htMakeButton('"\lisplink",message, mkCurryFun(func, value)) - bcIssueHt info - -beforeAfter(x,u) == [[y for [y,:r] in tails u while x ^= y],r] - -mkCurryFun(fun, val) == - name := GENTEMP() - code := - ['DEFUN, name, '(arg), ['APPLY, MKQ fun, ['CONS, 'arg, MKQ val]]] - EVAL code - name - -htRadioButtons [groupName, :buttons] == - htpSetRadioButtonAlist($curPage, [[groupName, :buttonNames buttons], - : htpRadioButtonAlist $curPage]) - boxesName := GENTEMP() - iht ['"\newline\indent{5}\radioboxes{", boxesName, - '"}{\htbmfile{pick}}{\htbmfile{unpick}}\beginitems "] - defaultValue := '"1" - for [message, info, buttonName] in buttons repeat - if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then - setUpDefault(buttonName, ['button, defaultValue]) - defaultValue := '"0" - iht ['"\item{\em\radiobox[", htpLabelDefault($curPage, buttonName), '"]{", - buttonName, '"}{",boxesName, '"}\space{}"] - bcIssueHt message - iht '"\space{}}" - bcIssueHt info - iht '"\enditems\indent{0} " - -htBcRadioButtons [groupName, :buttons] == - htpSetRadioButtonAlist($curPage, [[groupName, :buttonNames buttons], - : htpRadioButtonAlist $curPage]) - boxesName := GENTEMP() - iht ['"\radioboxes{", boxesName, - '"}{\htbmfile{pick}}{\htbmfile{unpick}} "] - defaultValue := '"1" - for [message, info, buttonName] in buttons repeat - if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then - setUpDefault(buttonName, ['button, defaultValue]) - defaultValue := '"0" - iht ['"{\em\radiobox[", htpLabelDefault($curPage, buttonName), '"]{", - buttonName, '"}{",boxesName, '"}"] - bcIssueHt message - iht '"\space{}}" - bcIssueHt info - -setUpDefault(name, props) == ----------------> OBSELETE <---------------- - htpAddInputAreaProp($curPage, name, props) - -buttonNames buttons == - [buttonName for [.,., buttonName] in buttons] - -htInputStrings strings == - iht '"\newline\indent{5}\beginitems " - for [mess1, mess2, numChars, default, stringName, spadType, :filter] - in strings repeat - if NULL LASSOC(stringName, htpInputAreaAlist $curPage) then - setUpDefault(stringName, ['string, default, spadType, filter]) - if htpLabelErrorMsg($curPage, stringName) then - iht ['"\centerline{{\em ", htpLabelErrorMsg($curPage, stringName), '"}}"] - - mess2 := CONCAT(mess2, bcSadFaces()) - htpSetLabelErrorMsg($curPage, stringName, nil) - iht '"\item " - bcIssueHt mess1 - iht ['"\inputstring{", stringName, '"}{", - numChars, '"}{", htpLabelDefault($curPage,stringName), '"} "] - bcIssueHt mess2 - iht '"\enditems\indent{0}\newline " - -htProcessDomainConditions condList == - htpSetDomainConditions($curPage, renamePatternVariables condList) - htpSetDomainVariableAlist($curPage, computeDomainVariableAlist()) - -renamePatternVariables condList == - htpSetDomainPvarSubstList($curPage, - renamePatternVariables1(condList, nil, $PatternVariableList)) - substFromAlist(condList, htpDomainPvarSubstList $curPage) - -renamePatternVariables1(condList, substList, patVars) == - null condList => substList - [cond, :restConds] := condList - cond is ['isDomain, pv, pattern] or cond is ['ofCategory, pv, pattern] - or cond is ['Satisfies, pv, cond] => - if pv = $EmptyMode then nsubst := substList - else nsubst := [[pv, :car patVars], :substList] - renamePatternVariables1(restConds, nsubst, rest patVars) - substList - -substFromAlist(l, substAlist) == - for [pvar, :replace] in substAlist repeat - l := SUBST(replace, pvar, l) - l - -computeDomainVariableAlist() == - [[pvar, :pvarCondList pvar] for [., :pvar] in - htpDomainPvarSubstList $curPage] - -pvarCondList pvar == - nreverse pvarCondList1([pvar], nil, htpDomainConditions $curPage) - -pvarCondList1(pvarList, activeConds, condList) == - null condList => activeConds - [cond, : restConds] := condList - cond is [., pv, pattern] and pv in pvarList => - pvarCondList1(nconc(pvarList, pvarsOfPattern pattern), - [cond, :activeConds], restConds) - pvarCondList1(pvarList, activeConds, restConds) - -pvarsOfPattern pattern == - NULL LISTP pattern => nil - [pvar for pvar in rest pattern | pvar in $PatternVariableList] - -htMakeTemplates(templateList, numLabels) == - templateList := [templateParts template for template in templateList] - [[substLabel(i, template) for template in templateList] - for i in 1..numLabels] where substLabel(i, template) == - PAIRP template => - INTERN CONCAT(first template, PRINC_-TO_-STRING i, rest template) - template - -templateParts template == - NULL STRINGP template => template - i := SEARCH('"%l", template) - null i => template - [SUBSEQ(template, 0, i), : SUBSEQ(template, i+2)] - -htMakeDoneButton(message, func) == - bcHt '"\newline\vspace{1}\centerline{" - if message = '"Continue" then - bchtMakeButton('"\lispdownlink", "\ContinueBitmap", func) - else - bchtMakeButton('"\lispdownlink",CONCAT('"\box{", message, '"}"), func) - bcHt '"} " - -htProcessDoneButton [label , func] == - iht '"\newline\vspace{1}\centerline{" - - if label = '"Continue" then - htMakeButton('"\lispdownlink", "\ContinueBitmap", func) - else if label = '"Push to enter names" then - htMakeButton('"\lispdownlink",'"\ControlBitmap{clicktoset}", func) - else - htMakeButton('"\lispdownlink", CONCAT('"\box{", label, '"}"), func) - - iht '"} " - -htMakeButton(htCommand, message, func,:options) == -----------> OBSELETE <---------------------------------- - skipStateInfo? := IFCAR options - iht [htCommand, '"{"] - bcIssueHt message - skipStateInfo? => - iht ['"}{(|htDoneButton| '|", func, '"| ",htpName $curPage, '")}"] - iht ['"}{(|htDoneButton| '|", func, '"| (PROGN "] - for [id, ., ., ., type, :.] in htpInputAreaAlist $curPage repeat - iht ['"(|htpSetLabelInputString| ", htpName $curPage, '"'|", id, '"| "] - if type = 'string then - iht ['"_"\stringvalue{", id, '"}_""] - else - iht ['"_"\boxvalue{", id, '"}_""] - iht '") " - iht [htpName $curPage, '"))}"] - -bchtMakeButton(htCommand, message, func) == - bcHt [htCommand, '"{", message, - '"}{(|htDoneButton| '|", func, '"| (PROGN "] - for [id, ., ., ., type, :.] in htpInputAreaAlist $curPage repeat - bcHt ['"(|htpSetLabelInputString| ", htpName $curPage, '"'|", id, '"| "] - if type = 'string then - bcHt ['"_"\stringvalue{", id, '"}_""] - else - bcHt ['"_"\boxvalue{", id, '"}_""] - bcHt '") " - bcHt [htpName $curPage, '"))} "] - -htProcessDoitButton [label, command, func] == - fun := mkCurryFun(func, [command]) - iht '"\newline\vspace{1}\centerline{" - htMakeButton('"\lispcommand", CONCAT('"\box{", label, '"}"), fun) - iht '"} " - iht '"\vspace{2}{Select \ \UpButton{} \ to go back one page.}" - iht '"\newline{Select \ \ExitButton{QuitPage} \ to remove this window.}" - -htMakeDoitButton(label, command) == - -- use bitmap button if just plain old "Do It" - if label = '"Do It" then - bcHt '"\newline\vspace{1}\centerline{\lispcommand{\DoItBitmap}{(|doDoitButton| " - else - bcHt ['"\newline\vspace{1}\centerline{\lispcommand{\box{", label, - '"}}{(|doDoitButton| "] - bcHt htpName $curPage - bcHt ['" _"", htEscapeString command, '"_""] - bcHt '")}}" - - bcHt '"\vspace{2}{Select \ \UpButton{} \ to go back one page.}" - bcHt '"\newline{Select \ \ExitButton{QuitPage} \ to remove this window.}" - -doDoitButton(htPage, command) == - executeInterpreterCommand command - -executeInterpreterCommand command == - PRINC command - TERPRI() - ncSetCurrentLine(command) - CATCH('SPAD__READER, parseAndInterpret command) - PRINC MKPROMPT() - FINISH_-OUTPUT() - -htDoneButton(func, htPage) == - typeCheckInputAreas htPage => - htMakeErrorPage htPage - NULL FBOUNDP func => - systemError ['"unknown function", func] - FUNCALL(SYMBOL_-FUNCTION func, htPage) - -typeCheckInputAreas htPage == - -- This needs to be severly beefed up - inputAlist := nil - errorCondition := false - for entry in htpInputAreaAlist htPage - | entry is [stringName, ., ., ., 'string, ., spadType, filter] repeat - condList := - LASSOC(LASSOC(spadType,htpDomainPvarSubstList htPage), - htpDomainVariableAlist htPage) - string := htpLabelFilteredInputString(htPage, stringName) - $bcParseOnly => - null ncParseFromString string => - htpSetLabelErrorMsg(htPage, '"Syntax Error", '"Syntax Error") - nil - val := checkCondition(htpLabelInputString(htPage, stringName), - string, condList) - STRINGP val => - errorCondition := true - htpSetLabelErrorMsg(htPage, stringName, val) - htpSetLabelSpadValue(htPage, stringName, val) - errorCondition - -checkCondition(s1, string, condList) == - condList is [['Satisfies, pvar, pred]] => - val := FUNCALL(pred, string) - STRINGP val => val - ['(String), :wrap s1] - condList isnt [['isDomain, pvar, pattern]] => - systemError '"currently invalid domain condition" - pattern is '(String) => ['(String), :wrap s1] - val := parseAndEval string - STRINGP val => - val = '"Syntax Error " => '"Error: Syntax Error " - condErrorMsg pattern - [type, : data] := val - newType := CATCH('SPAD__READER, resolveTM(type, pattern)) - null newType => - condErrorMsg pattern - coerceInt(val, newType) - -condErrorMsg type == - typeString := form2String type - if PAIRP typeString then typeString := APPLY(function CONCAT, typeString) - CONCAT('"Error: Could not make your input into a ", typeString) - -parseAndEval string == - $InteractiveMode :fluid := true - $BOOT: fluid := NIL - $SPAD: fluid := true - $e:fluid := $InteractiveFrame - $QuietCommand:local := true - parseAndEval1 string - -parseAndEval1 string == - syntaxError := false - pform := - $useNewParser => - v := applyWithOutputToString('ncParseFromString, [string]) - CAR v => CAR v - syntaxError := true - CDR v - oldParseString string - syntaxError => - '"Syntax Error " - pform => - val := applyWithOutputToString('processInteractive, [pform, nil]) - CAR val => CAR val - '"Type Analysis Error" - nil - -oldParseString string == - tree := applyWithOutputToString('string2SpadTree, [string]) - CAR tree => parseTransform postTransform CAR tree - CDR tree - -makeSpadCommand(:l) == - opForm := CONCAT(first l, '"(") - lastArg := last l - l := rest l - argList := nil - for arg in l while arg ^= lastArg repeat - argList := [CONCAT(arg, '", "), :argList] - argList := nreverse [lastArg, :argList] - CONCAT(opForm, APPLY(function CONCAT, argList), '")") - -htMakeInputList stringList == --- makes an input form for constructing a list - lastArg := last stringList - argList := nil - for arg in stringList while arg ^= lastArg repeat - argList := [CONCAT(arg, '", "), :argList] - argList := nreverse [lastArg, :argList] - bracketString APPLY(function CONCAT, argList) - - --- predefined filter strings -bracketString string == CONCAT('"[",string,'"]") - -quoteString string == CONCAT('"_"", string, '"_"") - -$funnyQuote := char 127 -$funnyBacks := char 128 - -htEscapeString str == - str := SUBSTITUTE($funnyQuote, char '_", str) - SUBSTITUTE($funnyBacks, char '_\, str) - -unescapeStringsInForm form == - STRINGP form => - str := NSUBSTITUTE(char '_", $funnyQuote, form) - NSUBSTITUTE(char '_\, $funnyBacks, str) - CONSP form => - unescapeStringsInForm CAR form - unescapeStringsInForm CDR form - form - form - - -htsv() == - startHTPage(50) - htSetVars() - -htSetVars() == - $path := nil - $lastTree := nil - if 0 ^= LASTATOM $setOptions then htMarkTree($setOptions,0) - htShowSetTree($setOptions) - -htShowSetTree(setTree) == - $path := TAKE(- LASTATOM setTree,$path) - page := htInitPage(mkSetTitle(),nil) - htpSetProperty(page, 'setTree, setTree) - links := nil - maxWidth1 := maxWidth2 := 0 - for setData in setTree repeat - satisfiesUserLevel setData.setLevel => - okList := [setData,:okList] - maxWidth1 := MAX(# PNAME setData.setName,maxWidth1) - maxWidth2 := MAX(htShowCount STRINGIMAGE setData.setLabel,maxWidth2) - maxWidth1 := MAX(9,maxWidth1) - maxWidth2 := MAX(41,maxWidth2) - tabset1 := STRINGIMAGE (maxWidth1) - tabset2 := STRINGIMAGE (maxWidth2 + maxWidth1 - 1) - htSay('"\tab{2}\newline Variable\tab{",STRINGIMAGE (maxWidth1 + (maxWidth2/3)),'"}Description\tab{",STRINGIMAGE(maxWidth2 + maxWidth1 + 2),'"}Value\newline\beginitems ") - for setData in REVERSE okList repeat - htSay '"\item" - label := STRCONC('"\menuitemstyle{",setData.setName,'"}") - links := [label,[['text,'"\tab{",tabset1,'"}",setData.setLabel,'"\tab{",tabset2,'"}{\em ",htShowSetTreeValue setData,'"}"]], - 'htShowSetPage, setData.setName] - htMakePage [['bcLispLinks, links,'options,'(indent . 0)]] - htSay '"\enditems" - htShowPage() - -htShowCount s == --# discounting {\em .. } - m := #s - m < 8 => m - 1 - i := 0 - count := 0 - while i < m - 7 repeat - s.i = char '_{ and s.(i+1) = char '_\ and s.(i+2) = char 'e - and s.(i+3) = char 'm => i := i + 6 --discount {\em } - i := i + 1 - count := count + 1 - count + (m - i) - -htShowSetTreeValue(setData) == - st := setData.setType - st = 'FUNCTION => object2String FUNCALL(setData.setVar,"%display%") - st = 'INTEGER => object2String eval setData.setVar - st = 'STRING => object2String eval setData.setVar - st = 'LITERALS => - object2String translateTrueFalse2YesNo eval setData.setVar - st = 'TREE => '"..." - systemError() - -mkSetTitle() == STRCONC('"Command {\em )set ",listOfStrings2String $path,'"}") - -listOfStrings2String u == - null u => '"" - STRCONC(listOfStrings2String rest u,'" ",stringize first u) - -htShowSetPage(htPage, branch) == - setTree := htpProperty(htPage, 'setTree) - $path := [branch,:TAKE(- LASTATOM setTree,$path)] - setData := ASSOC(branch, setTree) - null setData => - systemError('"No Set Data") - st := setData.setType - st = 'FUNCTION => htShowFunctionPage(htPage, setData) - st = 'INTEGER => htShowIntegerPage(htPage,setData) - st = 'LITERALS => htShowLiteralsPage(htPage, setData) - st = 'TREE => htShowSetTree(setData.setLeaf) - - st = 'STRING => -- have to add this - htSetNotAvailable(htPage,'")set compiler") - - systemError '"Unknown data type" - -htShowLiteralsPage(htPage, setData) == - htSetLiterals(htPage,setData.setName,setData.setLabel, - setData.setVar,setData.setLeaf,'htSetLiteral) - -htSetLiterals(htPage,name,message,variable,values,functionToCall) == - page := htInitPage('"Set Command", htpPropertyList htPage) - htpSetProperty(page, 'variable, variable) - bcHt ['"\centerline{Set {\em ", name, '"}}\newline"] - bcHt ['"{\em Description: } ", message, '"\newline\vspace{1} "] - bcHt '"Select one of the following: \newline\tab{3} " - links := [[STRCONC('"",STRINGIMAGE opt), '"\newline\tab{3}", functionToCall, opt] for opt in values] - htMakePage [['bcLispLinks, :links]] - bcHt ["\indent{0}\newline\vspace{1} The current setting is: {\em ", - translateTrueFalse2YesNo EVAL variable, '"} "] - htShowPage() - -htSetLiteral(htPage, val) == - htInitPage('"Set Command", nil) - SET(htpProperty(htPage, 'variable), translateYesNo2TrueFalse val) - htKill(htPage,val) - -htShowIntegerPage(htPage, setData) == - page := htInitPage(mkSetTitle(), htpPropertyList htPage) - htpSetProperty(page, 'variable, setData.setVar) - bcHt ['"\centerline{Set {\em ", setData.setName, '"}}\newline"] --- message := isKeyedMsgInDb($path,'(setvar text A)) or setData.setLabel - message := setData.setLabel - bcHt ['"{\em Description: } ", message, '"\newline\vspace{1} "] - [$htInitial,$htFinal] := setData.setLeaf - if $htFinal = $htInitial + 1 - then - bcHt '"Enter the integer {\em " - bcHt stringize $htInitial - bcHt '"} or {\em " - bcHt stringize $htFinal - bcHt '"}:" - else if null $htFinal then - bcHt '"Enter an integer greater than {\em " - bcHt stringize ($htInitial - 1) - bcHt '"}:" - else - bcHt '"Enter an integer between {\em " - bcHt stringize $htInitial - bcHt '"} and {\em " - bcHt stringize $htFinal - bcHt '"}:" - htMakePage [ - '(domainConditions (Satisfies S chkRange)), - ['bcStrings,[5,eval setData.setVar,'value,'S]]] - htSetvarDoneButton('"Select to Set Value",'htSetInteger) - htShowPage() - -htSetInteger(htPage) == - htInitPage(mkSetTitle(), nil) - val := chkRange htpLabelInputString(htPage,'value) - not INTEGERP val => - errorPage(htPage,['"Value Error",nil,'"\vspace{3}\centerline{{\em ",val,'"}}\vspace{2}\newline\centerline{Click on \UpBitmap{} to re-enter value}"]) - SET(htpProperty(htPage, 'variable), val) - htKill(htPage,val) - -htShowFunctionPage(htPage,setData) == - fn := setData.setDef => FUNCALL(fn,htPage) - htpSetProperty(htPage,'setData,setData) - htpSetProperty(htPage,'parts, setData.setLeaf) - htShowFunctionPageContinued(htPage) - -htShowFunctionPageContinued(htPage) == - parts := htpProperty(htPage,'parts) - setData := htpProperty(htPage,'setData) - [[phrase,kind,variable,checker,initValue,:.],:restParts] := parts - htpSetProperty(htPage, 'variable, variable) - htpSetProperty(htPage, 'checker, checker) - htpSetProperty(htPage, 'parts, restParts) - kind = 'LITERALS => htSetLiterals(htPage,setData.setName, - phrase,variable,checker,'htFunctionSetLiteral) - page := htInitPage(mkSetTitle(), htpPropertyList htPage) - bcHt ['"\centerline{Set {\em ", setData.setName, '"}}\newline"] - bcHt ['"{\em Description: } ", setData.setLabel, '"\newline\vspace{1} "] - currentValue := EVAL variable - htMakePage - [ ['domainConditions, ['Satisfies,'S,checker]], - ['text,:phrase], - ['inputStrings, - [ '"", '"", 60, currentValue, 'value, 'S]]] - htSetvarDoneButton('"Select To Set Value",'htSetFunCommand) - htShowPage() - -htSetvarDoneButton(message, func) == - bcHt '"\newline\vspace{1}\centerline{" - - if message = '"Select to Set Value" or message = '"Select to Set Values" then - bchtMakeButton('"\lisplink",'"\ControlBitmap{clicktoset}", func) - else - bchtMakeButton('"\lisplink",CONCAT('"\fbox{", message, '"}"), func) - - bcHt '"} " - - -htFunctionSetLiteral(htPage, val) == - htInitPage('"Set Command", nil) - SET(htpProperty(htPage, 'variable), translateYesNo2TrueFalse val) - htSetFunCommandContinue(htPage,val) - -htSetFunCommand(htPage) == - variable := htpProperty(htPage,'variable) - checker := htpProperty(htPage,'checker) - value := htCheck(checker,htpLabelInputString(htPage,'value)) - SET(variable,value) --kill this later - htSetFunCommandContinue(htPage,value) - -htSetFunCommandContinue(htPage,value) == - parts := htpProperty(htPage,'parts) - continue := - null parts => false - parts is [['break,predicate],:restParts] => eval predicate - true - continue => - htpSetProperty(htPage,'parts,restParts) - htShowFunctionPageContinued(htPage) - htKill(htPage,value) - -htKill(htPage,value) == - htInitPage('"System Command", nil) - string := STRCONC('"{\em )set ",listOfStrings2String [value,:$path],'"}") - htMakePage [ - '(text - "{Here is the AXIOM system command you could have issued:}" - "\vspace{2}\newline\centerline{\tt"), - ['text,:string]] - htMakePage '((text . "}\vspace{1}\newline\rm")) - htSay '"\vspace{2}{Select \ \UpButton{} \ to go back.}" - htSay '"\newline{Select \ \ExitButton{QuitPage} \ to remove this window.}" - htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] - htShowPage() - -htSetNotAvailable(htPage,whatToType) == - page := htInitPage('"Unavailable Set Command", htpPropertyList htPage) - htInitPage('"Unavailable System Command", nil) - string := STRCONC('"{\em ",whatToType,'"}") - htMakePage [ - '(text "\vspace{1}\newline" - "{Sorry, but this system command is not available through HyperDoc. Please directly issue this command in an AXIOM window for more information:}" - "\vspace{2}\newline\centerline{\tt"), - ['text,:string]] - htMakePage '((text . "}\vspace{1}\newline")) - htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] - htShowPage() - -htDoNothing(htPage,command) == nil - -htCheck(checker,value) == - PAIRP checker => htCheckList(checker,parseWord value) - FUNCALL(checker,value) - -parseWord x == - STRINGP x => - and/[DIGITP x.i for i in 0..MAXINDEX x] => PARSE_-INTEGER x - INTERN x - x - -htCheckList(checker,value) == - if value in '(y ye yes Y YE YES) then value := 'yes - if value in '(n no N NO) then value := 'no - checker is [n,m] and INTEGERP n => - m = n + 1 => - value in checker => value - n - null m => - INTEGERP value and value >= n => value - n - INTEGERP m => - INTEGERP value and value >= n and value <= m => value - n - value in checker => value - first checker --- emlist := "STRCONC"/[STRCONC('" {\em ",PNAME x,'"} ") for x in checker] --- STRCONC('"Please enter one of: ",emlist) - -translateYesNoToTrueFalse x == - x = 'yes => true - x = 'no => false - x - -chkNameList x == - u := bcString2ListWords x - parsedNames := [ncParseFromString x for x in u] - and/[IDENTP x for x in parsedNames] => parsedNames - '"Please enter a list of identifiers separated by blanks" - -chkPosInteger s == - (u := parseOnly s) and INTEGERP u and u > 0 => u - '"Please enter a positive integer" - -chkOutputFileName s == - bcString2WordList s in '(CONSOLE console) => 'console - chkDirectory s - -chkDirectory s == s - -chkNonNegativeInteger s == - (u := ncParseFromString s) and INTEGERP u and u >= 0 => u - '"Please enter a non-negative integer" - -chkRange s == - (u := ncParseFromString s) and INTEGERP u - and u >= $htInitial and (NULL $htFinal or u <= $htFinal) - => u - null $htFinal => - STRCONC('"Please enter an integer greater than ",stringize ($htInitial - 1)) - STRCONC('"Please enter an integer between ",stringize $htInitial,'" and ", - stringize $htFinal) - -chkAllNonNegativeInteger s == - (u := ncParseFromString s) and u in '(a al all A AL ALL) and 'ALL - or chkNonNegativeInteger s - or '"Please enter {\em all} or a non-negative integer" - -htMakePathKey path == - null path => systemError '"path is not set" - INTERN fn(PNAME first path,rest path) where - fn(a,b) == - null b => a - fn(STRCONC(a,'".",PNAME first b),rest b) - -htMarkTree(tree,n) == - RPLACD(LASTTAIL tree,n) - for branch in tree repeat - branch.3 = 'TREE => htMarkTree(branch.5,n + 1) - -htSetHistory htPage == - msg := "when the history facility is on (yes), results of computations are saved in memory" - data := ['history,msg,'history,'LITERALS,'$HiFiAccess,'(on off yes no)] - htShowLiteralsPage(htPage,data) - -htSetOutputLibrary htPage == - htSetNotAvailable(htPage,'")set compiler output") - -htSetInputLibrary htPage == - htSetNotAvailable(htPage,'")set compiler input") - -htSetExpose htPage == - htSetNotAvailable(htPage,'")set expose") - -htSetKernelProtect htPage == - htSetNotAvailable(htPage,'")set kernel protect") - -htSetKernelWarn htPage == - htSetNotAvailable(htPage,'")set kernel warn") - -htSetOutputCharacters htPage == - htSetNotAvailable(htPage,'")set output characters") - -htSetLinkerArgs htPage == - htSetNotAvailable(htPage,'")set fortran calling linker") - -htSetCache(htPage,:options) == - $path := '(functions cache) - htPage := htInitPage(mkSetTitle(),nil) - $valueList := nil - htMakePage '( - (text - "Use this system command to cause the AXIOM interpreter to `remember' " - "past values of interpreter functions. " - "To remember a past value of a function, the interpreter " - "sets up a {\em cache} for that function based on argument values. " - "When a value is cached for a given argument value, its value is gotten " - "from the cache and not recomputed. Caching can often save much " - "computing time, particularly with recursive functions or functions that " - "are expensive to compute and that are called repeatedly " - "with the same argument." - "\vspace{1}\newline ") - (domainConditions (Satisfies S chkNameList)) - (text - "Enter below a list of interpreter functions you would like specially cached. " - "Use the name {\em all} to give a default setting for all " - "interpreter functions. " - "\vspace{1}\newline " - "Enter {\em all} or a list of names (separate names by blanks):") - (inputStrings ("" "" 60 "all" names S)) - (doneButton "Push to enter names" htCacheAddChoice)) - htShowPage() - -htCacheAddChoice htPage == - names := bcString2WordList htpLabelInputString(htPage,'names) - $valueList := [listOfStrings2String names,:$valueList] - null names => htCacheAddQuery() - null rest names => htCacheOne names - page := htInitPage(mkSetTitle(),nil) - htpSetProperty(page,'names,names) - htMakePage '( - (domainConditions (Satisfies ALLPI chkAllPositiveInteger)) - (text - "For each function, enter below a {\em cache length}, a positive integer. " - "This number tells how many past values will " - "be cached. " - "A cache length of {\em 0} means the function won't be cached. " - "To cache all past values, " - "enter {\em all}." - "\vspace{1}\newline " - "For each function name, enter {\em all} or a positive integer:")) - for i in 1.. for name in names repeat htMakePage [ - ['inputStrings, - [STRCONC('"Function {\em ",name,'"} will cache"), - '"values",5,10,htMakeLabel('"c",i),'ALLPI]]] - htSetvarDoneButton('"Select to Set Values",'htCacheSet) - htShowPage() - -htMakeLabel(prefix,i) == INTERN STRCONC(prefix,stringize i) - -htCacheSet htPage == - names := htpProperty(htPage,'names) - for i in 1.. for name in names repeat - num := chkAllNonNegativeInteger - htpLabelInputString(htPage,htMakeLabel('"c",i)) - $cacheAlist := ADDASSOC(INTERN name,num,$cacheAlist) - if (n := LASSOC('all,$cacheAlist)) then - $cacheCount := n - $cacheAlist := deleteAssoc('all,$cacheAlist) - htInitPage('"Cache Summary",nil) - bcHt '"In general, interpreter functions " - bcHt - $cacheCount = 0 => "will {\em not} be cached." - bcHt '"cache " - htAllOrNum $cacheCount - '"} values." - bcHt '"\vspace{1}\newline " - if $cacheAlist then --- bcHt '" However, \indent{3}" - for [name,:val] in $cacheAlist | val ^= $cacheCount repeat - bcHt '"\newline function {\em " - bcHt stringize name - bcHt '"} will cache " - htAllOrNum val - bcHt '"} values" - htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] - htShowPage() - -htAllOrNum val == bcHt - val = 'all => '"{\em all" - val = 0 => '"{\em no" - STRCONC('"the last {\em ",stringize val) - -htCacheOne names == - page := htInitPage(mkSetTitle(),nil) - htpSetProperty(page,'names,names) - htMakePage '( - (domainConditions (Satisfies ALLPI chkAllPositiveInteger)) - (text - "Enter below a {\em cache length}, a positive integer. " - "This number tells how many past values will " - "be cached. To cache all past values, " - "enter {\em all}." - "\vspace{1}\newline ") - (inputStrings - ("Enter {\em all} or a positive integer:" - "" 5 10 c1 ALLPI))) - htSetvarDoneButton('"Select to Set Value",'htCacheSet) - htShowPage() - -$historyDisplayWidth := 120 -$newline := char 10 - -downlink page == - $saturn => downlinkSaturn page - htInitPage('"Bridge",nil) - htSay('"\replacepage{", page, '"}") - htShowPage() - -downlinkSaturn fn == - u := dbReadLines(fn) - lines := '"" - while u is [line,:u] repeat - n := MAXINDEX line - n < 1 => nil - line.0 = (char '_%) => nil - lines := STRCONC(lines,line) - issueHTSaturn lines - -dbNonEmptyPattern pattern == - null pattern => '"*" - pattern := STRINGIMAGE pattern - #pattern > 0 => pattern - '"*" - -htSystemVariables() == main where - main == - not $fullScreenSysVars => htSetVars() - classlevel := $UserLevel - $levels : local := '(compiler development interpreter) - $heading : local := nil - while classlevel ^= first $levels repeat $levels := rest $levels - table := NREVERSE fn($setOptions,nil,true) - htInitPage('"System Variables",nil) - htSay '"\beginmenu" - lastHeading := nil - for [heading,name,message,.,key,variable,options,func] in table repeat - htSay('"\newline\item ") - if heading = lastHeading then htSay '"\tab{8}" else - htSay(heading,'"\tab{8}") - lastHeading := heading - htSay('"{\em ",name,"}\tab{22}",message) - htSay('"\tab{80}") - key = 'FUNCTION => - null options => htMakePage [['bcLinks,['"reset",'"",func,nil]]] - [msg,class,var,valuesOrFunction,:.] := first options --skip first message - functionTail(name,class,var,valuesOrFunction) - for option in rest options repeat - option is ['break,:.] => 'skip - [msg,class,var,valuesOrFunction,:.] := option - htSay('"\newline\tab{22}", msg,'"\tab{80}") - functionTail(name,class,var,valuesOrFunction) - val := eval variable - displayOptions(name,key,variable,val,options) - htSay '"\endmenu" - htShowPage() - functionTail(name,class,var,valuesOrFunction) == - val := eval var - atom valuesOrFunction => - htMakePage '((domainConditions (isDomain STR (String)))) - htMakePage [['bcLinks,['"reset",'"",'htSetSystemVariableKind,[var,name,nil]]]] - htMakePage [['bcStrings,[30,STRINGIMAGE val,name,valuesOrFunction]]] - displayOptions(name,class,var,val,valuesOrFunction) - displayOptions(name,class,variable,val,options) == - class = 'INTEGER => - htMakePage [['bcLispLinks,[[['text,options.0,'"-",options.1 or '""]],'"",'htSetSystemVariableKind,[variable,name,'PARSE_-INTEGER]]]] - htMakePage '((domainConditions (isDomain INT (Integer)))) - htMakePage [['bcStrings,[5,STRINGIMAGE val,name,'INT]]] - class = 'STRING => - htSay('"{\em ",val,'"}\space{1}") - for x in options repeat - val = x or val = true and x = 'on or null val and x = 'off => - htSay('"{\em ",x,'"}\space{1}") - htMakePage [['bcLispLinks,[x,'" ",'htSetSystemVariable,[variable,x]]]] - fn(t,al,firstTime) == - atom t => al - if firstTime then $heading := opOf first t - fn(rest t,gn(first t,al),firstTime) - gn(t,al) == - [.,.,class,key,.,options,:.] := t - not MEMQ(class,$levels) => al - key = 'LITERALS or key = 'INTEGER or key = 'STRING => [[$heading,:t],:al] - key = 'TREE => fn(options,al,false) - key = 'FUNCTION => [[$heading,:t],:al] - systemError key - -htSetSystemVariableKind(htPage,[variable,name,fun]) == - value := htpLabelInputString(htPage,name) - if STRINGP value and fun then value := FUNCALL(fun,value) ---SCM::what to do??? if not FIXP value then userError ??? - SET(variable,value) - htSystemVariables () - -htSetSystemVariable(htPage,[name,value]) == - value := - value = 'on => true - value = 'off => nil - value - SET(name,value) - htSystemVariables () - -htGloss(pattern) == htGlossPage(nil,dbNonEmptyPattern pattern or '"*",true) - -htGlossPage(htPage,pattern,tryAgain?) == - $wildCard: local := char '_* - pattern = '"*" => downlink 'GlossaryPage - filter := pmTransFilter pattern - grepForm := mkGrepPattern(filter,'none) - $key: local := 'none - results := applyGrep(grepForm,'gloss) - --pathname := STRCONC('"/tmp/",PNAME resultFile,'".text.", getEnv '"SPADNUM") - --instream := MAKE_-INSTREAM pathname - defstream := MAKE_-INSTREAM STRCONC(getEnv '"AXIOM",'"/algebra/glossdef.text") - lines := gatherGlossLines(results,defstream) - -- OBEY STRCONC('"rm -f ", pathname) - --PROBE_-FILE(pathname) and DELETE_-FILE(pathname) - --SHUT instream - heading := - pattern = '"" => '"Glossary" - null lines => ['"No glossary items match {\em ",pattern,'"}"] - ['"Glossary items matching {\em ",pattern,'"}"] - null lines => - tryAgain? and #pattern > 0 => - (pattern.(k := MAXINDEX(pattern))) = char 's => - htGlossPage(htPage,SUBSTRING(pattern,0,k),true) - UPPER_-CASE_-P pattern.0 => - htGlossPage(htPage,DOWNCASE pattern,false) - errorPage(htPage,['"Sorry",nil,['"\centerline{",:heading,'"}"]]) - errorPage(htPage,['"Sorry",nil,['"\centerline{",:heading,'"}"]]) - htInitPageNoScroll(nil,heading) - htSay('"\beginscroll\beginmenu") - for line in lines repeat - tick := charPosition($tick,line,1) - htSay('"\item{\em \menuitemstyle{}}\tab{0}{\em ",escapeString SUBSTRING(line,0,tick),'"} ",SUBSTRING(line,tick + 1,nil)) - htSay '"\endmenu " - htSay '"\endscroll\newline " - htMakePage [['bcLinks,['"Search",'"",'htGlossSearch,nil]]] - htSay '" for glossary entry matching " - htMakePage [['bcStrings, [24,'"*",'filter,'EM]]] - htShowPageNoScroll() - -gatherGlossLines(results,defstream) == - acc := nil - for keyline in results repeat - --keyline := READLINE instream - n := charPosition($tick,keyline,0) - keyAndTick := SUBSTRING(keyline,0,n + 1) - byteAddress := string2Integer SUBSTRING(keyline,n + 1,nil) - FILE_-POSITION(defstream,byteAddress) - line := READLINE defstream - k := charPosition($tick,line,1) - pointer := SUBSTRING(line,0,k) - def := SUBSTRING(line,k + 1,nil) - xtralines := nil - while not EOFP defstream and (x := READLINE defstream) and - (j := charPosition($tick,x,1)) and (nextPointer := SUBSTRING(x,0,j)) - and (nextPointer = pointer) repeat - xtralines := [SUBSTRING(x,j + 1,nil),:xtralines] - acc := [STRCONC(keyAndTick,def, "STRCONC"/NREVERSE xtralines),:acc] - REVERSE acc - -htGlossSearch(htPage,junk) == htGloss htpLabelInputString(htPage,'filter) - -htGreekSearch(filter) == - ss := dbNonEmptyPattern filter - s := pmTransFilter ss - s is ['error,:.] => bcErrorPage s - not s => errorPage(nil,[['"Missing search string"],nil, - '"\vspace{2}\centerline{To select one of the greek letters:}\newline ", - '"\centerline{{\em first} enter a search key into the input area}\newline ", - '"\centerline{{\em then } move the mouse cursor to the work {\em search} and click}"]) - filter := patternCheck s - names := '(alpha beta gamma delta epsilon zeta eta theta iota kappa lambda mu nu pi) - for x in names repeat - superMatch?(filter,PNAME x) => matches := [x,:matches] - nonmatches := [x,:nonmatches] - matches := NREVERSE matches - nonmatches := NREVERSE nonmatches - htInitPage('"Greek Names",nil) - null matches => - htInitPage(['"Greek names matching search string {\em ",ss,'"}"],nil) - 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}") - htShowPage() - htInitPage(['"Greek letters matching search string {\em ",ss,'"}"],nil) - if nonmatches - then htSay('"The greek letters that {\em match} your search string {\em ",ss,'"}:") - else htSay('"Your search string {\em ",ss,"} matches all of the greek letters:") - htSay('"{\em \table{") - for x in matches repeat htSay('"{",x,'"}") - htSay('"}}\vspace{1}") - if nonmatches then - htSay('"The greek letters that {\em do not match} your search string:{\em \table{") - for x in nonmatches repeat htSay('"{",x,'"}") - htSay('"}}") - htShowPage() - -htTextSearch(filter) == - s := pmTransFilter dbNonEmptyPattern filter - s is ['error,:.] => bcErrorPage s - not s => errorPage(nil,[['"Missing search string"],nil, - '"\vspace{2}\centerline{To select one of the lines of text:}\newline ", - '"\centerline{{\em first} enter a search key into the input area}\newline ", - '"\centerline{{\em then } move the mouse cursor to the work {\em search} and click}"]) - filter := s - lines := ['"{{\em Fruit flies} *like* a {\em banana and califlower ears.}}", - '"{{\em Sneak Sears Silas with Savings Snatch}}"] - for x in lines repeat - superMatch?(filter,x) => matches := [x,:matches] - nonmatches := [x,:nonmatches] - matches := NREVERSE matches - nonmatches := NREVERSE nonmatches - htInitPage('"Text Matches",nil) - null matches => - htInitPage(['"Lines matching search string {\em ",s,'"}"],nil) - htSay("\vspace{2}\centerline{Sorry, but no lines match your search string}\centerline{{\em ",s,"}}\centerline{Click on the up-arrow to try again}") - htShowPage() - htInitPage(['"Lines matching search string {\em ",s,'"}"],nil) - if nonmatches - then htSay('"The lines that {\em match} your search string {\em ",s,'"}:") - else htSay('"Your search string {\em ",s,"} matches both lines:") - htSay('"{\em \table{") - for x in matches repeat htSay('"{",x,'"}") - htSay('"}}\vspace{1}") - if nonmatches then - htSay('"The line that {\em does not match} your search string:{\em \table{") - for x in nonmatches repeat htSay('"{",x,'"}") - htSay('"}}") - htShowPage() - -htTutorialSearch pattern == - s := dbNonEmptyPattern pattern or return - errorPage(nil,['"Empty search key",nil,'"\vspace{3}\centerline{You must enter some search string"]) - s := mkUnixPattern s - source := '"$AXIOM/doc/hypertex/pages/ht.db" - target :='"/tmp/temp.text.$SPADNUM" - OBEY STRCONC('"$AXIOM/lib/hthits",'" _"",s,'"_" ",source,'" > ",target) - lines := dbReadLines 'temp - htInitPageNoScroll(nil,['"Tutorial Pages mentioning {\em ",pattern,'"}"]) - htSay('"\beginscroll\table{") - for line in lines repeat - [name,title,.] := dbParts(line,3,0) - htSay ['"{\downlink{",title,'"}{",name,'"}}"] - htSay '"}" - htShowPage() - -mkUnixPattern s == - u := mkUpDownPattern s - starPositions := REVERSE [i for i in 1..(-1 + MAXINDEX u) | u.i = $wild] - for i in starPositions repeat - u := STRCONC(SUBSTRING(u,0,i),'".*",SUBSTRING(u,i + 1,nil)) - if u.0 ^= $wild then u := STRCONC('"[^a-zA-Z]",u) - else u := SUBSTRING(u,1,nil) - if u.(k := MAXINDEX u) ^= $wild then u := STRCONC(u,'"[^a-zA-Z]") - else u := SUBSTRING(u,0,k) - u - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/ht-util.lisp.pamphlet b/src/interp/ht-util.lisp.pamphlet new file mode 100644 index 0000000..663d9b3 --- /dev/null +++ b/src/interp/ht-util.lisp.pamphlet @@ -0,0 +1,4653 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp ht-util.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<<*>>= +(IN-PACKAGE "BOOT" ) + +;-- HyperTeX Utilities for generating basic Command pages +;--)package "BOOT" +;$bcParseOnly := true + +(SPADLET |$bcParseOnly| 'T) + +;-- List of issued hypertex lines +;$htLineList := nil + +(SPADLET |$htLineList| NIL) + +;-- pointer to the page we are currently defining +;$curPage := nil + +(SPADLET |$curPage| NIL) + +;-- List of currently active window named +;$activePageList := nil + +(SPADLET |$activePageList| NIL) + +;htpDestroyPage(pageName) == +; pageName in $activePageList => +; SET(pageName, nil) +; $activePageList := NREMOVE($activePageList, pageName) + +(DEFUN |htpDestroyPage| (|pageName|) + (declare (special |$activePageList|)) + (SEQ (COND + ((|member| |pageName| |$activePageList|) + (EXIT (PROGN + (SET |pageName| NIL) + (SPADLET |$activePageList| + (NREMOVE |$activePageList| |pageName|)))))))) + +;htpName htPage == +;-- GENSYM whose value is the page +; ELT(htPage, 0) + +(DEFUN |htpName| (|htPage|) (ELT |htPage| 0)) + +;htpSetName(htPage, val) == +; SETELT(htPage, 0, val) + +(DEFUN |htpSetName| (|htPage| |val|) (SETELT |htPage| 0 |val|)) + +;htpDomainConditions htPage == +;-- List of Domain conditions +; ELT(htPage, 1) + +(DEFUN |htpDomainConditions| (|htPage|) (ELT |htPage| 1)) + +;htpSetDomainConditions(htPage, val) == +; SETELT(htPage, 1, val) + +(DEFUN |htpSetDomainConditions| (|htPage| |val|) + (SETELT |htPage| 1 |val|)) + +;htpDomainVariableAlist htPage == +;-- alist of pattern variables and conditions +; ELT(htPage, 2) + +(DEFUN |htpDomainVariableAlist| (|htPage|) (ELT |htPage| 2)) + +;htpSetDomainVariableAlist(htPage, val) == +; SETELT(htPage, 2, val) + +(DEFUN |htpSetDomainVariableAlist| (|htPage| |val|) + (SETELT |htPage| 2 |val|)) + +;htpDomainPvarSubstList htPage == +;-- alist of user pattern variables to system vars +; ELT(htPage, 3) + +(DEFUN |htpDomainPvarSubstList| (|htPage|) (ELT |htPage| 3)) + +;htpSetDomainPvarSubstList(htPage, val) == +; SETELT(htPage, 3, val) + +(DEFUN |htpSetDomainPvarSubstList| (|htPage| |val|) + (SETELT |htPage| 3 |val|)) + +;htpRadioButtonAlist htPage == +;-- alist of radio button group names and labels +; ELT(htPage, 4) + +(DEFUN |htpRadioButtonAlist| (|htPage|) (ELT |htPage| 4)) + +;htpButtonValue(htPage, groupName) == +; for buttonName in LASSOC(groupName, htpRadioButtonAlist htPage) repeat +; (stripSpaces htpLabelInputString(htPage, buttonName)) = '"t" => +; return buttonName + +(DEFUN |htpButtonValue| (|htPage| |groupName|) + (PROG () + (RETURN + (SEQ (DO ((G166092 + (LASSOC |groupName| + (|htpRadioButtonAlist| |htPage|)) + (CDR G166092)) + (|buttonName| NIL)) + ((OR (ATOM G166092) + (PROGN (SETQ |buttonName| (CAR G166092)) NIL)) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL + (|stripSpaces| + (|htpLabelInputString| |htPage| + |buttonName|)) + (MAKESTRING "t")) + (EXIT (RETURN |buttonName|))))))))))) + +;htpSetRadioButtonAlist(htPage, val) == +; SETELT(htPage, 4, val) + +(DEFUN |htpSetRadioButtonAlist| (|htPage| |val|) + (SETELT |htPage| 4 |val|)) + +;htpInputAreaAlist htPage == +;-- Alist of input-area labels, and default values +; ELT(htPage, 5) + +(DEFUN |htpInputAreaAlist| (|htPage|) (ELT |htPage| 5)) + +;htpSetInputAreaAlist(htPage, val) == +; SETELT(htPage, 5, val) + +(DEFUN |htpSetInputAreaAlist| (|htPage| |val|) + (SETELT |htPage| 5 |val|)) + +;htpAddInputAreaProp(htPage, label, prop) == +; SETELT(htPage, 5, [[label, nil, nil, nil, :prop], :ELT(htPage, 5)]) + +(DEFUN |htpAddInputAreaProp| (|htPage| |label| |prop|) + (SETELT |htPage| 5 + (CONS (CONS |label| (CONS NIL (CONS NIL (CONS NIL |prop|)))) + (ELT |htPage| 5)))) + +;htpPropertyList htPage == +;-- Association list of user-defined properties +; ELT(htPage, 6) + +(DEFUN |htpPropertyList| (|htPage|) (ELT |htPage| 6)) + +;htpProperty(htPage, propName) == +; LASSOC(propName, ELT(htPage, 6)) + +(DEFUN |htpProperty| (|htPage| |propName|) + (LASSOC |propName| (ELT |htPage| 6))) + +;htpSetProperty(htPage, propName, val) == +; pair := ASSOC(propName, ELT(htPage, 6)) +; pair => RPLACD(pair, val) +; SETELT(htPage, 6, [[propName, :val], :ELT(htPage, 6)]) + +(DEFUN |htpSetProperty| (|htPage| |propName| |val|) + (PROG (|pair|) + (RETURN + (PROGN + (SPADLET |pair| (|assoc| |propName| (ELT |htPage| 6))) + (COND + (|pair| (RPLACD |pair| |val|)) + ('T + (SETELT |htPage| 6 + (CONS (CONS |propName| |val|) (ELT |htPage| 6))))))))) + +;htpLabelInputString(htPage, label) == +;-- value user typed as input string on page +; props := LASSOC(label, htpInputAreaAlist htPage) +; props and STRINGP (s := ELT(props,0)) => +; s = '"" => s +; trimString s +; nil + +(DEFUN |htpLabelInputString| (|htPage| |label|) + (PROG (|props| |s|) + (RETURN + (PROGN + (SPADLET |props| + (LASSOC |label| (|htpInputAreaAlist| |htPage|))) + (COND + ((AND |props| (STRINGP (SPADLET |s| (ELT |props| 0)))) + (COND + ((BOOT-EQUAL |s| (MAKESTRING "")) |s|) + ('T (|trimString| |s|)))) + ('T NIL)))))) + +;htpLabelFilteredInputString(htPage, label) == +;-- value user typed as input string on page +; props := LASSOC(label, htpInputAreaAlist htPage) +; props => +; #props > 5 and ELT(props, 6) => +; FUNCALL(SYMBOL_-FUNCTION ELT(props, 6), ELT(props, 0)) +; replacePercentByDollar ELT(props, 0) +; nil + +(DEFUN |htpLabelFilteredInputString| (|htPage| |label|) + (PROG (|props|) + (RETURN + (PROGN + (SPADLET |props| + (LASSOC |label| (|htpInputAreaAlist| |htPage|))) + (COND + (|props| (COND + ((AND (> (|#| |props|) 5) (ELT |props| 6)) + (FUNCALL (SYMBOL-FUNCTION (ELT |props| 6)) + (ELT |props| 0))) + ('T (|replacePercentByDollar| (ELT |props| 0))))) + ('T NIL)))))) + +;replacePercentByDollar s == fn(s,0,MAXINDEX s) where +; fn(s,i,n) == +; i > n => '"" +; (m := charPosition(char "%",s,i)) > n => SUBSTRING(s,i,nil) +; STRCONC(SUBSTRING(s,i,m - i),'"$",fn(s,m + 1,n)) + +(DEFUN |replacePercentByDollar,fn| (|s| |i| |n|) + (PROG (|m|) + (RETURN + (SEQ (IF (> |i| |n|) (EXIT (MAKESTRING ""))) + (IF (> (SPADLET |m| (|charPosition| (|char| '%) |s| |i|)) + |n|) + (EXIT (SUBSTRING |s| |i| NIL))) + (EXIT (STRCONC (SUBSTRING |s| |i| (SPADDIFFERENCE |m| |i|)) + (MAKESTRING "$") + (|replacePercentByDollar,fn| |s| (PLUS |m| 1) + |n|))))))) + + +(DEFUN |replacePercentByDollar| (|s|) + (|replacePercentByDollar,fn| |s| 0 (MAXINDEX |s|))) + +;htpSetLabelInputString(htPage, label, val) == +;------------------> OBSELETE +;-- value user typed as input string on page +; props := LASSOC(label, htpInputAreaAlist htPage) +; props => SETELT(props, 0, STRINGIMAGE val) +; nil + +(DEFUN |htpSetLabelInputString| (|htPage| |label| |val|) + (PROG (|props|) + (RETURN + (PROGN + (SPADLET |props| + (LASSOC |label| (|htpInputAreaAlist| |htPage|))) + (COND + (|props| (SETELT |props| 0 (STRINGIMAGE |val|))) + ('T NIL)))))) + +;htpLabelSpadValue(htPage, label) == +;-- Scratchpad value of parsed and evaled inputString, as (type . value) +; props := LASSOC(label, htpInputAreaAlist htPage) +; props => ELT(props, 1) +; nil + +(DEFUN |htpLabelSpadValue| (|htPage| |label|) + (PROG (|props|) + (RETURN + (PROGN + (SPADLET |props| + (LASSOC |label| (|htpInputAreaAlist| |htPage|))) + (COND (|props| (ELT |props| 1)) ('T NIL)))))) + +;htpSetLabelSpadValue(htPage, label, val) == +;-- value user typed as input string on page +; props := LASSOC(label, htpInputAreaAlist htPage) +; props => SETELT(props, 1, val) +; nil + +(DEFUN |htpSetLabelSpadValue| (|htPage| |label| |val|) + (PROG (|props|) + (RETURN + (PROGN + (SPADLET |props| + (LASSOC |label| (|htpInputAreaAlist| |htPage|))) + (COND (|props| (SETELT |props| 1 |val|)) ('T NIL)))))) + +;htpLabelErrorMsg(htPage, label) == +;-- error message associated with input area +; props := LASSOC(label, htpInputAreaAlist htPage) +; props => ELT(props, 2) +; nil + +(DEFUN |htpLabelErrorMsg| (|htPage| |label|) + (PROG (|props|) + (RETURN + (PROGN + (SPADLET |props| + (LASSOC |label| (|htpInputAreaAlist| |htPage|))) + (COND (|props| (ELT |props| 2)) ('T NIL)))))) + +;htpSetLabelErrorMsg(htPage, label, val) == +;-- error message associated with input area +; props := LASSOC(label, htpInputAreaAlist htPage) +; props => SETELT(props, 2, val) +; nil + +(DEFUN |htpSetLabelErrorMsg| (|htPage| |label| |val|) + (PROG (|props|) + (RETURN + (PROGN + (SPADLET |props| + (LASSOC |label| (|htpInputAreaAlist| |htPage|))) + (COND (|props| (SETELT |props| 2 |val|)) ('T NIL)))))) + +;htpLabelType(htPage, label) == +;-- either 'string or 'button +; props := LASSOC(label, htpInputAreaAlist htPage) +; props => ELT(props, 3) +; nil + +(DEFUN |htpLabelType| (|htPage| |label|) + (PROG (|props|) + (RETURN + (PROGN + (SPADLET |props| + (LASSOC |label| (|htpInputAreaAlist| |htPage|))) + (COND (|props| (ELT |props| 3)) ('T NIL)))))) + +;htpLabelDefault(htPage, label) == +;-- default value for the input area +; msg := htpLabelInputString(htPage, label) => +; msg = '"t" => 1 +; msg = '"nil" => 0 +; msg +; props := LASSOC(label, htpInputAreaAlist htPage) +; props => +; ELT(props, 4) +; nil + +(DEFUN |htpLabelDefault| (|htPage| |label|) + (PROG (|msg| |props|) + (RETURN + (COND + ((SPADLET |msg| (|htpLabelInputString| |htPage| |label|)) + (COND + ((BOOT-EQUAL |msg| (MAKESTRING "t")) 1) + ((BOOT-EQUAL |msg| (MAKESTRING "nil")) 0) + ('T |msg|))) + ('T + (SPADLET |props| + (LASSOC |label| (|htpInputAreaAlist| |htPage|))) + (COND (|props| (ELT |props| 4)) ('T NIL))))))) + +;htpLabelSpadType(htPage, label) == +;-- pattern variable for target domain for input area +; props := LASSOC(label, htpInputAreaAlist htPage) +; props => ELT(props, 5) +; nil + +(DEFUN |htpLabelSpadType| (|htPage| |label|) + (PROG (|props|) + (RETURN + (PROGN + (SPADLET |props| + (LASSOC |label| (|htpInputAreaAlist| |htPage|))) + (COND (|props| (ELT |props| 5)) ('T NIL)))))) + +;htpLabelFilter(htPage, label) == +;-- string to string mapping applied to input area strings before parsing +; props := LASSOC(label, htpInputAreaAlist htPage) +; props => ELT(props, 6) +; nil + +(DEFUN |htpLabelFilter| (|htPage| |label|) + (PROG (|props|) + (RETURN + (PROGN + (SPADLET |props| + (LASSOC |label| (|htpInputAreaAlist| |htPage|))) + (COND (|props| (ELT |props| 6)) ('T NIL)))))) + +;htpPageDescription htPage == +;-- a list of all the commands issued to create the basic-command page +; ELT(htPage, 7) + +(DEFUN |htpPageDescription| (|htPage|) (ELT |htPage| 7)) + +;htpSetPageDescription(htPage, pageDescription) == +; SETELT(htPage, 7, pageDescription) + +(DEFUN |htpSetPageDescription| (|htPage| |pageDescription|) + (SETELT |htPage| 7 |pageDescription|)) + +;htpAddToPageDescription(htPage, pageDescrip) == +;-------------> OBSELETE <----------- +; SETELT(htPage, 7, nconc(nreverse COPY_-LIST pageDescrip, ELT(htPage, 7))) + +(DEFUN |htpAddToPageDescription| (|htPage| |pageDescrip|) + (SETELT |htPage| 7 + (NCONC (NREVERSE (COPY-LIST |pageDescrip|)) (ELT |htPage| 7)))) + +;iht line == +;-- issue a single hyperteTeX line, or a group of lines +; $newPage => nil +; PAIRP line => +; $htLineList := NCONC(nreverse mapStringize COPY_-LIST line, $htLineList) +; $htLineList := [basicStringize line, :$htLineList] + +(DEFUN |iht| (|line|) + (declare (special |$htLineList| |$newPage|)) + (COND + (|$newPage| NIL) + ((PAIRP |line|) + (SPADLET |$htLineList| + (NCONC (NREVERSE (|mapStringize| (COPY-LIST |line|))) + |$htLineList|))) + ('T + (SPADLET |$htLineList| + (CONS (|basicStringize| |line|) |$htLineList|))))) + +;bcHt line == +;--line = '"\##1" => harharhar() +; iht line +; PAIRP line => +; if $newPage then htpAddToPageDescription($curPage, [['text, :line]]) +; if $newPage then htpAddToPageDescription($curPage, [['text, line]]) + +(DEFUN |bcHt| (|line|) + (declare (special |$curPage| |$newPage|)) + (PROGN + (|iht| |line|) + (COND + ((PAIRP |line|) + (COND + (|$newPage| + (|htpAddToPageDescription| |$curPage| + (CONS (CONS '|text| |line|) NIL))) + ('T NIL))) + (|$newPage| + (|htpAddToPageDescription| |$curPage| + (CONS (CONS '|text| (CONS |line| NIL)) NIL))) + ('T NIL)))) + +;bcIssueHt line == +; PAIRP line => htMakePage1 line +; iht line + +(DEFUN |bcIssueHt| (|line|) + (COND ((PAIRP |line|) (|htMakePage1| |line|)) ('T (|iht| |line|)))) + +;mapStringize l == +; ATOM l => l +; RPLACA(l, basicStringize CAR l) +; RPLACD(l, mapStringize CDR l) +; l + +(DEFUN |mapStringize| (|l|) + (COND + ((ATOM |l|) |l|) + ('T (RPLACA |l| (|basicStringize| (CAR |l|))) + (RPLACD |l| (|mapStringize| (CDR |l|))) |l|))) + +;basicStringize s == +; STRINGP s => +; s = '"\$" => '"\%" +; s = '"{\em $}" => '"{\em \%}" +; s +; s = '_$ => '"\%" +; PRINC_-TO_-STRING s + +(DEFUN |basicStringize| (|s|) + (COND + ((STRINGP |s|) + (COND + ((BOOT-EQUAL |s| (MAKESTRING "\\$")) (MAKESTRING "\\%")) + ((BOOT-EQUAL |s| (MAKESTRING "{\\em $}")) + (MAKESTRING "{\\em \\%}")) + ('T |s|))) + ((BOOT-EQUAL |s| '$) (MAKESTRING "\\%")) + ('T (PRINC-TO-STRING |s|)))) + +;stringize s == +; STRINGP s => s +; PRINC_-TO_-STRING s + +(DEFUN |stringize| (|s|) + (COND ((STRINGP |s|) |s|) ('T (PRINC-TO-STRING |s|)))) + +;htInitPage(title, propList) == +;----------------------------> OBSELETE---cannot return $curPage +;-- start defining a hyperTeX page +; htInitPageNoScroll(propList, title) +; htSayStandard '"\beginscroll " +; $curPage + +(DEFUN |htInitPage| (|title| |propList|) + (declare (special |$curPage|)) + (PROGN + (|htInitPageNoScroll| |propList| |title|) + (|htSayStandard| (MAKESTRING "\\beginscroll ")) + |$curPage|)) + +;--htInitPageNoHeading(propList) == +;-----------------------> replaced by htInitPageNoScroll +;-- start defining a hyperTeX page +;-- $curPage := htpMakeEmptyPage(propList) +;-- if $saturn then $saturnPage := htpMakeEmptyPage(propList) +;-- $newPage := true +;-- $htLineList := nil +;-- $curPage +;htAddHeading(title) == +;------------------------> OBSELETE +; htNewPage title +; $curPage + +(DEFUN |htAddHeading| (|title|) + (declare (special |$curPage|)) + (PROGN (|htNewPage| |title|) |$curPage|)) + +;htShowPage() == +;-- show the page which has been computed +; htSayStandard '"\endscroll" +; htShowPageNoScroll() + +(DEFUN |htShowPage| () + (PROGN + (|htSayStandard| (MAKESTRING "\\endscroll")) + (|htShowPageNoScroll|))) + +;htShowPageNoScroll() == +;------------------------> OBSELETE +;-- show the page which has been computed +; htSayStandard '"\autobuttons" +; htpSetPageDescription($curPage, nreverse htpPageDescription $curPage) +; $newPage := false +; $htLineList := nil +; htMakePage htpPageDescription $curPage +; line := APPLY(function CONCAT, nreverse $htLineList) +; issueHT line +; endHTPage() + +(DEFUN |htShowPageNoScroll| () + (PROG (|line|) + (declare (special |$htLineList| |$curPage| |$newPage|)) + (RETURN + (PROGN + (|htSayStandard| (MAKESTRING "\\autobuttons")) + (|htpSetPageDescription| |$curPage| + (NREVERSE (|htpPageDescription| |$curPage|))) + (SPADLET |$newPage| NIL) + (SPADLET |$htLineList| NIL) + (|htMakePage| (|htpPageDescription| |$curPage|)) + (SPADLET |line| (APPLY (|function| CONCAT) (NREVERSE |$htLineList|))) + (|issueHT| |line|) + (|endHTPage|))))) + +;htMakePage itemList == +;------------------------> OBSELETE +;-- make a page given the description in itemList +; if $newPage then htpAddToPageDescription($curPage, itemList) +; htMakePage1 itemList + +(DEFUN |htMakePage| (|itemList|) + (declare (special |$curPage| |$newPage|)) + (PROGN + (COND + (|$newPage| (|htpAddToPageDescription| |$curPage| |itemList|))) + (|htMakePage1| |itemList|))) + +;htMakePage1 itemList == +;-- make a page given the description in itemList +; for [itemType, :items] in itemList repeat +; itemType = 'text => iht items +; itemType = 'lispLinks => htLispLinks items +; itemType = 'lispmemoLinks => htLispMemoLinks items +; itemType = 'bcLinks => htBcLinks items ---> +; itemType = 'bcLinksNS => htBcLinks(items,true) +; itemType = 'bcLispLinks => htBcLispLinks items ---> +; itemType = 'radioButtons => htRadioButtons items +; itemType = 'bcRadioButtons => htBcRadioButtons items +; itemType = 'inputStrings => htInputStrings items +; itemType = 'domainConditions => htProcessDomainConditions items +; itemType = 'bcStrings => htProcessBcStrings items +; itemType = 'toggleButtons => htProcessToggleButtons items +; itemType = 'bcButtons => htProcessBcButtons items +; itemType = 'doneButton => htProcessDoneButton items +; itemType = 'doitButton => htProcessDoitButton items +; systemError ['"unknown itemType", itemType] + +(DEFUN |htMakePage1| (|itemList|) + (PROG (|itemType| |items|) + (RETURN + (SEQ (DO ((G166261 |itemList| (CDR G166261)) (G166253 NIL)) + ((OR (ATOM G166261) + (PROGN (SETQ G166253 (CAR G166261)) NIL) + (PROGN + (PROGN + (SPADLET |itemType| (CAR G166253)) + (SPADLET |items| (CDR G166253)) + G166253) + NIL)) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL |itemType| '|text|) + (|iht| |items|)) + ((BOOT-EQUAL |itemType| '|lispLinks|) + (|htLispLinks| |items|)) + ((BOOT-EQUAL |itemType| '|lispmemoLinks|) + (|htLispMemoLinks| |items|)) + ((BOOT-EQUAL |itemType| '|bcLinks|) + (|htBcLinks| |items|)) + ((BOOT-EQUAL |itemType| '|bcLinksNS|) + (|htBcLinks| |items| 'T)) + ((BOOT-EQUAL |itemType| '|bcLispLinks|) + (|htBcLispLinks| |items|)) + ((BOOT-EQUAL |itemType| '|radioButtons|) + (|htRadioButtons| |items|)) + ((BOOT-EQUAL |itemType| '|bcRadioButtons|) + (|htBcRadioButtons| |items|)) + ((BOOT-EQUAL |itemType| '|inputStrings|) + (|htInputStrings| |items|)) + ((BOOT-EQUAL |itemType| '|domainConditions|) + (|htProcessDomainConditions| |items|)) + ((BOOT-EQUAL |itemType| '|bcStrings|) + (|htProcessBcStrings| |items|)) + ((BOOT-EQUAL |itemType| '|toggleButtons|) + (|htProcessToggleButtons| |items|)) + ((BOOT-EQUAL |itemType| '|bcButtons|) + (|htProcessBcButtons| |items|)) + ((BOOT-EQUAL |itemType| '|doneButton|) + (|htProcessDoneButton| |items|)) + ((BOOT-EQUAL |itemType| '|doitButton|) + (|htProcessDoitButton| |items|)) + ('T + (|systemError| + (CONS (MAKESTRING "unknown itemType") + (CONS |itemType| NIL)))))))))))) + +;htMakeErrorPage htPage == +;------------------> OBSELETE +; $newPage := false +; $htLineList := nil +; $curPage := htPage +; htMakePage htpPageDescription htPage +; line := APPLY(function CONCAT, nreverse $htLineList) +; issueHT line +; endHTPage() + +(DEFUN |htMakeErrorPage| (|htPage|) + (PROG (|line|) + (declare (special |$curPage| |$htLineList| |$newPage|)) + (RETURN + (PROGN + (SPADLET |$newPage| NIL) + (SPADLET |$htLineList| NIL) + (SPADLET |$curPage| |htPage|) + (|htMakePage| (|htpPageDescription| |htPage|)) + (SPADLET |line| (APPLY (|function| CONCAT) (NREVERSE |$htLineList|))) + (|issueHT| |line|) + (|endHTPage|))))) + +;htQuote s == +;-- wrap quotes around a piece of hyperTeX +; iht '"_"" +; iht s +; iht '"_"" + +(DEFUN |htQuote| (|s|) + (PROGN + (|iht| (MAKESTRING "\"")) + (|iht| |s|) + (|iht| (MAKESTRING "\"")))) + +;htProcessToggleButtons buttons == +; iht '"\newline\indent{5}\beginitems " +; for [message, info, defaultValue, buttonName] in buttons repeat +; if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then +; setUpDefault(buttonName, ['button, defaultValue]) +; iht ['"\item{\em\inputbox[", htpLabelDefault($curPage, buttonName), '"]{", +; buttonName, '"}{\htbmfile{pick}}{\htbmfile{unpick}}\space{}"] +; bcIssueHt message +; iht '"\space{}}" +; bcIssueHt info +; iht '"\enditems\indent{0} " + +(DEFUN |htProcessToggleButtons| (|buttons|) + (PROG (|message| |info| |defaultValue| |buttonName|) + (declare (special |$curPage|)) + (RETURN + (SEQ (PROGN + (|iht| (MAKESTRING "\\newline\\indent{5}\\beginitems ")) + (DO ((G166302 |buttons| (CDR G166302)) + (G166286 NIL)) + ((OR (ATOM G166302) + (PROGN (SETQ G166286 (CAR G166302)) NIL) + (PROGN + (PROGN + (SPADLET |message| (CAR G166286)) + (SPADLET |info| (CADR G166286)) + (SPADLET |defaultValue| (CADDR G166286)) + (SPADLET |buttonName| (CADDDR G166286)) + G166286) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + ((NULL (LASSOC |buttonName| + (|htpInputAreaAlist| |$curPage|))) + (|setUpDefault| |buttonName| + (CONS '|button| + (CONS |defaultValue| NIL))))) + (|iht| (CONS + (MAKESTRING + "\\item{\\em\\inputbox[") + (CONS + (|htpLabelDefault| |$curPage| + |buttonName|) + (CONS (MAKESTRING "]{") + (CONS |buttonName| + (CONS + (MAKESTRING + "}{\\htbmfile{pick}}{\\htbmfile{unpick}}\\space{}") + NIL)))))) + (|bcIssueHt| |message|) + (|iht| (MAKESTRING "\\space{}}")) + (|bcIssueHt| |info|))))) + (|iht| (MAKESTRING "\\enditems\\indent{0} "))))))) + +;htProcessBcButtons buttons == +; for [defaultValue, buttonName] in buttons repeat +; if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then +; setUpDefault(buttonName, ['button, defaultValue]) +; k := htpLabelDefault($curPage,buttonName) +; k = 0 => iht ['"\off{",buttonName,'"}"] +; k = 1 => iht ['"\on{", buttonName,'"}"] +; iht ['"\inputbox[", htpLabelDefault($curPage, buttonName), '"]{", +; buttonName, '"}{\htbmfile{pick}}{\htbmfile{unpick}}"] + +(DEFUN |htProcessBcButtons| (|buttons|) + (PROG (|defaultValue| |buttonName| |k|) + (declare (special |$curPage|)) + (RETURN + (SEQ (DO ((G166328 |buttons| (CDR G166328)) (G166317 NIL)) + ((OR (ATOM G166328) + (PROGN (SETQ G166317 (CAR G166328)) NIL) + (PROGN + (PROGN + (SPADLET |defaultValue| (CAR G166317)) + (SPADLET |buttonName| (CADR G166317)) + G166317) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + ((NULL (LASSOC |buttonName| + (|htpInputAreaAlist| |$curPage|))) + (|setUpDefault| |buttonName| + (CONS '|button| + (CONS |defaultValue| NIL))))) + (SPADLET |k| + (|htpLabelDefault| |$curPage| + |buttonName|)) + (COND + ((EQL |k| 0) + (|iht| (CONS (MAKESTRING "\\off{") + (CONS |buttonName| + (CONS (MAKESTRING "}") NIL))))) + ((EQL |k| 1) + (|iht| (CONS (MAKESTRING "\\on{") + (CONS |buttonName| + (CONS (MAKESTRING "}") NIL))))) + ('T + (|iht| (CONS (MAKESTRING "\\inputbox[") + (CONS + (|htpLabelDefault| |$curPage| + |buttonName|) + (CONS (MAKESTRING "]{") + (CONS |buttonName| + (CONS + (MAKESTRING + "}{\\htbmfile{pick}}{\\htbmfile{unpick}}") + NIL)))))))))))))))) + +;htProcessBcStrings strings == +;---------------------> OBSELETE <------------------------ +; for [numChars, default, stringName, spadType, :filter] in strings repeat +; mess2 := '"" +; if NULL LASSOC(stringName, htpInputAreaAlist $curPage) then +; setUpDefault(stringName, ['string, default, spadType, filter]) +; if htpLabelErrorMsg($curPage, stringName) then +; iht ['"\centerline{{\em ", htpLabelErrorMsg($curPage, stringName), '"}}"] +; mess2 := CONCAT(mess2, bcSadFaces()) +; htpSetLabelErrorMsg($curPage, stringName, nil) +; iht ['"\inputstring{", stringName, '"}{", +; numChars, '"}{", htpLabelDefault($curPage,stringName), '"} ", mess2] + +(DEFUN |htProcessBcStrings| (|strings|) + (PROG (|numChars| |default| |stringName| |spadType| |filter| |mess2|) + (declare (special |$curPage|)) + (RETURN + (SEQ (DO ((G166358 |strings| (CDR G166358)) (G166343 NIL)) + ((OR (ATOM G166358) + (PROGN (SETQ G166343 (CAR G166358)) NIL) + (PROGN + (PROGN + (SPADLET |numChars| (CAR G166343)) + (SPADLET |default| (CADR G166343)) + (SPADLET |stringName| (CADDR G166343)) + (SPADLET |spadType| (CADDDR G166343)) + (SPADLET |filter| (CDDDDR G166343)) + G166343) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |mess2| (MAKESTRING "")) + (COND + ((NULL (LASSOC |stringName| + (|htpInputAreaAlist| |$curPage|))) + (|setUpDefault| |stringName| + (CONS '|string| + (CONS |default| + (CONS |spadType| + (CONS |filter| NIL))))))) + (COND + ((|htpLabelErrorMsg| |$curPage| + |stringName|) + (|iht| (CONS + (MAKESTRING "\\centerline{{\\em ") + (CONS + (|htpLabelErrorMsg| |$curPage| + |stringName|) + (CONS (MAKESTRING "}}") NIL)))) + (SPADLET |mess2| + (CONCAT |mess2| (|bcSadFaces|))) + (|htpSetLabelErrorMsg| |$curPage| + |stringName| NIL))) + (|iht| (CONS (MAKESTRING "\\inputstring{") + (CONS |stringName| + (CONS (MAKESTRING "}{") + (CONS |numChars| + (CONS (MAKESTRING "}{") + (CONS + (|htpLabelDefault| + |$curPage| |stringName|) + (CONS (MAKESTRING "} ") + (CONS |mess2| NIL))))))))))))))))) + +;bcSadFaces() == +; '"\space{1}{\em\htbitmap{error}\htbitmap{error}\htbitmap{error}}" + +(DEFUN |bcSadFaces| () + (MAKESTRING + "\\space{1}{\\em\\htbitmap{error}\\htbitmap{error}\\htbitmap{error}}")) + +;htLispLinks(links,:option) == +; [links,options] := beforeAfter('options,links) +; indent := LASSOC('indent,options) or 5 +; iht '"\newline\indent{" +; iht stringize indent +; iht '"}\beginitems" +; for [message, info, func, :value] in links repeat +; iht '"\item[" +; call := (IFCAR option => '"\lispmemolink"; '"\lispdownlink") +; htMakeButton(call,message, mkCurryFun(func, value)) +; iht ['"]\space{}"] +; bcIssueHt info +; iht '"\enditems\indent{0} " + +(DEFUN |htLispLinks| (&REST G166422 &AUX |option| |links|) + (DSETQ (|links| . |option|) G166422) + (PROG (|LETTMP#1| |options| |indent| |message| |info| |func| |value| + |call|) + (RETURN + (SEQ (PROGN + (SPADLET |LETTMP#1| (|beforeAfter| '|options| |links|)) + (SPADLET |links| (CAR |LETTMP#1|)) + (SPADLET |options| (CADR |LETTMP#1|)) + (SPADLET |indent| (OR (LASSOC '|indent| |options|) 5)) + (|iht| (MAKESTRING "\\newline\\indent{")) + (|iht| (|stringize| |indent|)) + (|iht| (MAKESTRING "}\\beginitems")) + (DO ((G166403 |links| (CDR G166403)) (G166387 NIL)) + ((OR (ATOM G166403) + (PROGN (SETQ G166387 (CAR G166403)) NIL) + (PROGN + (PROGN + (SPADLET |message| (CAR G166387)) + (SPADLET |info| (CADR G166387)) + (SPADLET |func| (CADDR G166387)) + (SPADLET |value| (CDDDR G166387)) + G166387) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|iht| (MAKESTRING "\\item[")) + (SPADLET |call| + (COND + ((IFCAR |option|) + (MAKESTRING "\\lispmemolink")) + ('T + (MAKESTRING "\\lispdownlink")))) + (|htMakeButton| |call| |message| + (|mkCurryFun| |func| |value|)) + (|iht| (CONS (MAKESTRING "]\\space{}") NIL)) + (|bcIssueHt| |info|))))) + (|iht| (MAKESTRING "\\enditems\\indent{0} "))))))) + +;htLispMemoLinks(links) == htLispLinks(links,true) + +(DEFUN |htLispMemoLinks| (|links|) (|htLispLinks| |links| 'T)) + +;htBcLinks(links,:options) == +;-------------------------> OBSELETE +; skipStateInfo? := IFCAR options +; [links,options] := beforeAfter('options,links) +; for [message, info, func, :value] in links repeat +; htMakeButton('"\lispdownlink",message, +; mkCurryFun(func, value),skipStateInfo?) +; bcIssueHt info + +(DEFUN |htBcLinks| (&REST G166465 &AUX |options| |links|) + (DSETQ (|links| . |options|) G166465) + (PROG (|skipStateInfo?| |LETTMP#1| |message| |info| |func| |value|) + (RETURN + (SEQ (PROGN + (SPADLET |skipStateInfo?| (IFCAR |options|)) + (SPADLET |LETTMP#1| (|beforeAfter| '|options| |links|)) + (SPADLET |links| (CAR |LETTMP#1|)) + (SPADLET |options| (CADR |LETTMP#1|)) + (DO ((G166447 |links| (CDR G166447)) (G166434 NIL)) + ((OR (ATOM G166447) + (PROGN (SETQ G166434 (CAR G166447)) NIL) + (PROGN + (PROGN + (SPADLET |message| (CAR G166434)) + (SPADLET |info| (CADR G166434)) + (SPADLET |func| (CADDR G166434)) + (SPADLET |value| (CDDDR G166434)) + G166434) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|htMakeButton| + (MAKESTRING "\\lispdownlink") |message| + (|mkCurryFun| |func| |value|) + |skipStateInfo?|) + (|bcIssueHt| |info|)))))))))) + +;htBcLispLinks links == +;-------------------------> OBSELETE +; [links,options] := beforeAfter('options,links) +; for [message, info, func, :value] in links repeat +; htMakeButton('"\lisplink",message, mkCurryFun(func, value)) +; bcIssueHt info + +(DEFUN |htBcLispLinks| (|links|) + (PROG (|LETTMP#1| |options| |message| |info| |func| |value|) + (RETURN + (SEQ (PROGN + (SPADLET |LETTMP#1| (|beforeAfter| '|options| |links|)) + (SPADLET |links| (CAR |LETTMP#1|)) + (SPADLET |options| (CADR |LETTMP#1|)) + (DO ((G166487 |links| (CDR G166487)) (G166474 NIL)) + ((OR (ATOM G166487) + (PROGN (SETQ G166474 (CAR G166487)) NIL) + (PROGN + (PROGN + (SPADLET |message| (CAR G166474)) + (SPADLET |info| (CADR G166474)) + (SPADLET |func| (CADDR G166474)) + (SPADLET |value| (CDDDR G166474)) + G166474) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|htMakeButton| (MAKESTRING "\\lisplink") + |message| + (|mkCurryFun| |func| |value|)) + (|bcIssueHt| |info|)))))))))) + +;beforeAfter(x,u) == [[y for [y,:r] in tails u while x ^= y],r] + +(DEFUN |beforeAfter| (|x| |u|) + (PROG (|y| |r|) + (RETURN + (SEQ (CONS (PROG (G166514) + (SPADLET G166514 NIL) + (RETURN + (DO ((G166504 |u| (CDR G166504))) + ((OR (ATOM G166504) + (PROGN + (PROGN + (SPADLET |y| (CAR G166504)) + (SPADLET |r| (CDR G166504)) + G166504) + NIL) + (NULL (NEQUAL |x| |y|))) + (NREVERSE0 G166514)) + (SEQ (EXIT (SETQ G166514 (CONS |y| G166514))))))) + (CONS |r| NIL)))))) + +;mkCurryFun(fun, val) == +; name := GENTEMP() +; code := +; ['DEFUN, name, '(arg), ['APPLY, MKQ fun, ['CONS, 'arg, MKQ val]]] +; EVAL code +; name + +(DEFUN |mkCurryFun| (|fun| |val|) + (PROG (|name| |code|) + (RETURN + (PROGN + (SPADLET |name| (GENTEMP)) + (SPADLET |code| + (CONS 'DEFUN + (CONS |name| + (CONS '(|arg|) + (CONS + (CONS 'APPLY + (CONS (MKQ |fun|) + (CONS + (CONS 'CONS + (CONS '|arg| + (CONS (MKQ |val|) NIL))) + NIL))) + NIL))))) + (EVAL |code|) + |name|)))) + +;htRadioButtons [groupName, :buttons] == +; htpSetRadioButtonAlist($curPage, [[groupName, :buttonNames buttons], +; : htpRadioButtonAlist $curPage]) +; boxesName := GENTEMP() +; iht ['"\newline\indent{5}\radioboxes{", boxesName, +; '"}{\htbmfile{pick}}{\htbmfile{unpick}}\beginitems "] +; defaultValue := '"1" +; for [message, info, buttonName] in buttons repeat +; if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then +; setUpDefault(buttonName, ['button, defaultValue]) +; defaultValue := '"0" +; iht ['"\item{\em\radiobox[", htpLabelDefault($curPage, buttonName), '"]{", +; buttonName, '"}{",boxesName, '"}\space{}"] +; bcIssueHt message +; iht '"\space{}}" +; bcIssueHt info +; iht '"\enditems\indent{0} " + +(DEFUN |htRadioButtons| (G166546) + (PROG (|groupName| |buttons| |boxesName| |message| |info| + |buttonName| |defaultValue|) + (declare (special |$curPage|)) + (RETURN + (SEQ (PROGN + (SPADLET |groupName| (CAR G166546)) + (SPADLET |buttons| (CDR G166546)) + (|htpSetRadioButtonAlist| |$curPage| + (CONS (CONS |groupName| (|buttonNames| |buttons|)) + (|htpRadioButtonAlist| |$curPage|))) + (SPADLET |boxesName| (GENTEMP)) + (|iht| (CONS (MAKESTRING + "\\newline\\indent{5}\\radioboxes{") + (CONS |boxesName| + (CONS (MAKESTRING + "}{\\htbmfile{pick}}{\\htbmfile{unpick}}\\beginitems ") + NIL)))) + (SPADLET |defaultValue| (MAKESTRING "1")) + (DO ((G166568 |buttons| (CDR G166568)) + (G166540 NIL)) + ((OR (ATOM G166568) + (PROGN (SETQ G166540 (CAR G166568)) NIL) + (PROGN + (PROGN + (SPADLET |message| (CAR G166540)) + (SPADLET |info| (CADR G166540)) + (SPADLET |buttonName| (CADDR G166540)) + G166540) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + ((NULL (LASSOC |buttonName| + (|htpInputAreaAlist| |$curPage|))) + (|setUpDefault| |buttonName| + (CONS '|button| + (CONS |defaultValue| NIL))) + (SPADLET |defaultValue| + (MAKESTRING "0")))) + (|iht| (CONS + (MAKESTRING + "\\item{\\em\\radiobox[") + (CONS + (|htpLabelDefault| |$curPage| + |buttonName|) + (CONS (MAKESTRING "]{") + (CONS |buttonName| + (CONS (MAKESTRING "}{") + (CONS |boxesName| + (CONS + (MAKESTRING "}\\space{}") + NIL)))))))) + (|bcIssueHt| |message|) + (|iht| (MAKESTRING "\\space{}}")) + (|bcIssueHt| |info|))))) + (|iht| (MAKESTRING "\\enditems\\indent{0} "))))))) + +;htBcRadioButtons [groupName, :buttons] == +; htpSetRadioButtonAlist($curPage, [[groupName, :buttonNames buttons], +; : htpRadioButtonAlist $curPage]) +; boxesName := GENTEMP() +; iht ['"\radioboxes{", boxesName, +; '"}{\htbmfile{pick}}{\htbmfile{unpick}} "] +; defaultValue := '"1" +; for [message, info, buttonName] in buttons repeat +; if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then +; setUpDefault(buttonName, ['button, defaultValue]) +; defaultValue := '"0" +; iht ['"{\em\radiobox[", htpLabelDefault($curPage, buttonName), '"]{", +; buttonName, '"}{",boxesName, '"}"] +; bcIssueHt message +; iht '"\space{}}" +; bcIssueHt info + +(DEFUN |htBcRadioButtons| (G166594) + (PROG (|groupName| |buttons| |boxesName| |message| |info| + |buttonName| |defaultValue|) + (declare (special |$curPage|)) + (RETURN + (SEQ (PROGN + (SPADLET |groupName| (CAR G166594)) + (SPADLET |buttons| (CDR G166594)) + (|htpSetRadioButtonAlist| |$curPage| + (CONS (CONS |groupName| (|buttonNames| |buttons|)) + (|htpRadioButtonAlist| |$curPage|))) + (SPADLET |boxesName| (GENTEMP)) + (|iht| (CONS (MAKESTRING "\\radioboxes{") + (CONS |boxesName| + (CONS (MAKESTRING + "}{\\htbmfile{pick}}{\\htbmfile{unpick}} ") + NIL)))) + (SPADLET |defaultValue| (MAKESTRING "1")) + (DO ((G166616 |buttons| (CDR G166616)) + (G166588 NIL)) + ((OR (ATOM G166616) + (PROGN (SETQ G166588 (CAR G166616)) NIL) + (PROGN + (PROGN + (SPADLET |message| (CAR G166588)) + (SPADLET |info| (CADR G166588)) + (SPADLET |buttonName| (CADDR G166588)) + G166588) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + ((NULL (LASSOC |buttonName| + (|htpInputAreaAlist| |$curPage|))) + (|setUpDefault| |buttonName| + (CONS '|button| + (CONS |defaultValue| NIL))) + (SPADLET |defaultValue| + (MAKESTRING "0")))) + (|iht| (CONS + (MAKESTRING "{\\em\\radiobox[") + (CONS + (|htpLabelDefault| |$curPage| + |buttonName|) + (CONS (MAKESTRING "]{") + (CONS |buttonName| + (CONS (MAKESTRING "}{") + (CONS |boxesName| + (CONS (MAKESTRING "}") NIL)))))))) + (|bcIssueHt| |message|) + (|iht| (MAKESTRING "\\space{}}")) + (|bcIssueHt| |info|)))))))))) + +;setUpDefault(name, props) == +;---------------> OBSELETE <---------------- +; htpAddInputAreaProp($curPage, name, props) + +(DEFUN |setUpDefault| (|name| |props|) + (declare (special |$curPage|)) + (|htpAddInputAreaProp| |$curPage| |name| |props|)) + +;buttonNames buttons == +; [buttonName for [.,., buttonName] in buttons] + +(DEFUN |buttonNames| (|buttons|) + (PROG (|buttonName|) + (RETURN + (SEQ (PROG (G166645) + (SPADLET G166645 NIL) + (RETURN + (DO ((G166651 |buttons| (CDR G166651)) + (G166637 NIL)) + ((OR (ATOM G166651) + (PROGN (SETQ G166637 (CAR G166651)) NIL) + (PROGN + (PROGN + (SPADLET |buttonName| (CADDR G166637)) + G166637) + NIL)) + (NREVERSE0 G166645)) + (SEQ (EXIT (SETQ G166645 + (CONS |buttonName| G166645))))))))))) + +;htInputStrings strings == +; iht '"\newline\indent{5}\beginitems " +; for [mess1, mess2, numChars, default, stringName, spadType, :filter] +; in strings repeat +; if NULL LASSOC(stringName, htpInputAreaAlist $curPage) then +; setUpDefault(stringName, ['string, default, spadType, filter]) +; if htpLabelErrorMsg($curPage, stringName) then +; iht ['"\centerline{{\em ", htpLabelErrorMsg($curPage, stringName), '"}}"] +; mess2 := CONCAT(mess2, bcSadFaces()) +; htpSetLabelErrorMsg($curPage, stringName, nil) +; iht '"\item " +; bcIssueHt mess1 +; iht ['"\inputstring{", stringName, '"}{", +; numChars, '"}{", htpLabelDefault($curPage,stringName), '"} "] +; bcIssueHt mess2 +; iht '"\enditems\indent{0}\newline " + +(DEFUN |htInputStrings| (|strings|) + (PROG (|mess1| |numChars| |default| |stringName| |spadType| |filter| |mess2|) + (declare (special |$curPage|)) + (RETURN + (SEQ (PROGN + (|iht| (MAKESTRING "\\newline\\indent{5}\\beginitems ")) + (DO ((G166685 |strings| (CDR G166685)) + (G166665 NIL)) + ((OR (ATOM G166685) + (PROGN (SETQ G166665 (CAR G166685)) NIL) + (PROGN + (PROGN + (SPADLET |mess1| (CAR G166665)) + (SPADLET |mess2| (CADR G166665)) + (SPADLET |numChars| (CADDR G166665)) + (SPADLET |default| (CADDDR G166665)) + (SPADLET |stringName| + (CAR (CDDDDR G166665))) + (SPADLET |spadType| + (CADR (CDDDDR G166665))) + (SPADLET |filter| (CDDR (CDDDDR G166665))) + G166665) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + ((NULL (LASSOC |stringName| + (|htpInputAreaAlist| |$curPage|))) + (|setUpDefault| |stringName| + (CONS '|string| + (CONS |default| + (CONS |spadType| + (CONS |filter| NIL))))))) + (COND + ((|htpLabelErrorMsg| |$curPage| + |stringName|) + (|iht| (CONS + (MAKESTRING + "\\centerline{{\\em ") + (CONS + (|htpLabelErrorMsg| |$curPage| + |stringName|) + (CONS (MAKESTRING "}}") NIL)))) + (SPADLET |mess2| + (CONCAT |mess2| (|bcSadFaces|))) + (|htpSetLabelErrorMsg| |$curPage| + |stringName| NIL))) + (|iht| (MAKESTRING "\\item ")) + (|bcIssueHt| |mess1|) + (|iht| (CONS (MAKESTRING "\\inputstring{") + (CONS |stringName| + (CONS (MAKESTRING "}{") + (CONS |numChars| + (CONS (MAKESTRING "}{") + (CONS + (|htpLabelDefault| |$curPage| + |stringName|) + (CONS (MAKESTRING "} ") NIL)))))))) + (|bcIssueHt| |mess2|))))) + (|iht| (MAKESTRING "\\enditems\\indent{0}\\newline "))))))) + +;htProcessDomainConditions condList == +; htpSetDomainConditions($curPage, renamePatternVariables condList) +; htpSetDomainVariableAlist($curPage, computeDomainVariableAlist()) + +(DEFUN |htProcessDomainConditions| (|condList|) + (declare (special |$curPage|)) + (PROGN + (|htpSetDomainConditions| |$curPage| + (|renamePatternVariables| |condList|)) + (|htpSetDomainVariableAlist| |$curPage| + (|computeDomainVariableAlist|)))) + +;renamePatternVariables condList == +; htpSetDomainPvarSubstList($curPage, +; renamePatternVariables1(condList, nil, $PatternVariableList)) +; substFromAlist(condList, htpDomainPvarSubstList $curPage) + +(DEFUN |renamePatternVariables| (|condList|) + (declare (special |$curPage| |$PatternVariableList|)) + (PROGN + (|htpSetDomainPvarSubstList| |$curPage| + (|renamePatternVariables1| |condList| NIL + |$PatternVariableList|)) + (|substFromAlist| |condList| (|htpDomainPvarSubstList| |$curPage|)))) + +;renamePatternVariables1(condList, substList, patVars) == +; null condList => substList +; [cond, :restConds] := condList +; cond is ['isDomain, pv, pattern] or cond is ['ofCategory, pv, pattern] +; or cond is ['Satisfies, pv, cond] => +; if pv = $EmptyMode then nsubst := substList +; else nsubst := [[pv, :car patVars], :substList] +; renamePatternVariables1(restConds, nsubst, rest patVars) +; substList + +(DEFUN |renamePatternVariables1| (|condList| |substList| |patVars|) + (PROG (|restConds| |pattern| |ISTMP#1| |pv| |ISTMP#2| |cond| |nsubst|) + (declare (special |$EmptyMode|)) + (RETURN + (COND + ((NULL |condList|) |substList|) + ('T (SPADLET |cond| (CAR |condList|)) + (SPADLET |restConds| (CDR |condList|)) + (COND + ((OR (AND (PAIRP |cond|) (EQ (QCAR |cond|) '|isDomain|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cond|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pv| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |pattern| + (QCAR |ISTMP#2|)) + 'T)))))) + (AND (PAIRP |cond|) (EQ (QCAR |cond|) '|ofCategory|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cond|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pv| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |pattern| + (QCAR |ISTMP#2|)) + 'T)))))) + (AND (PAIRP |cond|) (EQ (QCAR |cond|) '|Satisfies|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cond|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pv| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |cond| (QCAR |ISTMP#2|)) + 'T))))))) + (COND + ((BOOT-EQUAL |pv| |$EmptyMode|) + (SPADLET |nsubst| |substList|)) + ('T + (SPADLET |nsubst| + (CONS (CONS |pv| (CAR |patVars|)) |substList|)))) + (|renamePatternVariables1| |restConds| |nsubst| + (CDR |patVars|))) + ('T |substList|))))))) + +;substFromAlist(l, substAlist) == +; for [pvar, :replace] in substAlist repeat +; l := SUBST(replace, pvar, l) +; l + +(DEFUN |substFromAlist| (|l| |substAlist|) + (PROG (|pvar| |replace|) + (RETURN + (SEQ (PROGN + (DO ((G166792 |substAlist| (CDR G166792)) + (G166783 NIL)) + ((OR (ATOM G166792) + (PROGN (SETQ G166783 (CAR G166792)) NIL) + (PROGN + (PROGN + (SPADLET |pvar| (CAR G166783)) + (SPADLET |replace| (CDR G166783)) + G166783) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |l| (MSUBST |replace| |pvar| |l|))))) + |l|))))) + +;computeDomainVariableAlist() == +; [[pvar, :pvarCondList pvar] for [., :pvar] in +; htpDomainPvarSubstList $curPage] + +(DEFUN |computeDomainVariableAlist| () + (PROG (|pvar|) + (declare (special |$curPage|)) + (RETURN + (SEQ (PROG (G166813) + (SPADLET G166813 NIL) + (RETURN + (DO ((G166819 (|htpDomainPvarSubstList| |$curPage|) + (CDR G166819)) + (G166805 NIL)) + ((OR (ATOM G166819) + (PROGN (SETQ G166805 (CAR G166819)) NIL) + (PROGN + (PROGN + (SPADLET |pvar| (CDR G166805)) + G166805) + NIL)) + (NREVERSE0 G166813)) + (SEQ (EXIT (SETQ G166813 + (CONS (CONS |pvar| + (|pvarCondList| |pvar|)) + G166813))))))))))) + +;pvarCondList pvar == +; nreverse pvarCondList1([pvar], nil, htpDomainConditions $curPage) + +(DEFUN |pvarCondList| (|pvar|) + (declare (special |$curPage|)) + (NREVERSE + (|pvarCondList1| (CONS |pvar| NIL) NIL + (|htpDomainConditions| |$curPage|)))) + +;pvarCondList1(pvarList, activeConds, condList) == +; null condList => activeConds +; [cond, : restConds] := condList +; cond is [., pv, pattern] and pv in pvarList => +; pvarCondList1(nconc(pvarList, pvarsOfPattern pattern), +; [cond, :activeConds], restConds) +; pvarCondList1(pvarList, activeConds, restConds) + +(DEFUN |pvarCondList1| (|pvarList| |activeConds| |condList|) + (PROG (|cond| |restConds| |ISTMP#1| |pv| |ISTMP#2| |pattern|) + (RETURN + (COND + ((NULL |condList|) |activeConds|) + ('T (SPADLET |cond| (CAR |condList|)) + (SPADLET |restConds| (CDR |condList|)) + (COND + ((AND (PAIRP |cond|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cond|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pv| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |pattern| (QCAR |ISTMP#2|)) + 'T))))) + (|member| |pv| |pvarList|)) + (|pvarCondList1| + (NCONC |pvarList| (|pvarsOfPattern| |pattern|)) + (CONS |cond| |activeConds|) |restConds|)) + ('T (|pvarCondList1| |pvarList| |activeConds| |restConds|)))))))) + +;pvarsOfPattern pattern == +; NULL LISTP pattern => nil +; [pvar for pvar in rest pattern | pvar in $PatternVariableList] + +(DEFUN |pvarsOfPattern| (|pattern|) + (PROG () + (declare (special |$PatternVariableList|)) + (RETURN + (SEQ (COND + ((NULL (LISTP |pattern|)) NIL) + ('T + (PROG (G166869) + (SPADLET G166869 NIL) + (RETURN + (DO ((G166875 (CDR |pattern|) (CDR G166875)) + (|pvar| NIL)) + ((OR (ATOM G166875) + (PROGN (SETQ |pvar| (CAR G166875)) NIL)) + (NREVERSE0 G166869)) + (SEQ (EXIT (COND + ((|member| |pvar| + |$PatternVariableList|) + (SETQ G166869 + (CONS |pvar| G166869))))))))))))))) + +;htMakeTemplates(templateList, numLabels) == +; templateList := [templateParts template for template in templateList] +; [[substLabel(i, template) for template in templateList] +; for i in 1..numLabels] where substLabel(i, template) == +; PAIRP template => +; INTERN CONCAT(first template, PRINC_-TO_-STRING i, rest template) +; template + +(DEFUN |htMakeTemplates,substLabel| (|i| |template|) + (SEQ (IF (PAIRP |template|) + (EXIT (INTERN (CONCAT (CAR |template|) (PRINC-TO-STRING |i|) + (CDR |template|))))) + (EXIT |template|))) + +(DEFUN |htMakeTemplates| (|templateList| |numLabels|) + (PROG () + (RETURN + (SEQ (PROGN + (SPADLET |templateList| + (PROG (G166895) + (SPADLET G166895 NIL) + (RETURN + (DO ((G166900 |templateList| + (CDR G166900)) + (|template| NIL)) + ((OR (ATOM G166900) + (PROGN + (SETQ |template| (CAR G166900)) + NIL)) + (NREVERSE0 G166895)) + (SEQ (EXIT (SETQ G166895 + (CONS + (|templateParts| |template|) + G166895)))))))) + (PROG (G166910) + (SPADLET G166910 NIL) + (RETURN + (DO ((|i| 1 (QSADD1 |i|))) + ((QSGREATERP |i| |numLabels|) + (NREVERSE0 G166910)) + (SEQ (EXIT (SETQ G166910 + (CONS + (PROG (G166922) + (SPADLET G166922 NIL) + (RETURN + (DO + ((G166927 |templateList| + (CDR G166927)) + (|template| NIL)) + ((OR (ATOM G166927) + (PROGN + (SETQ |template| + (CAR G166927)) + NIL)) + (NREVERSE0 G166922)) + (SEQ + (EXIT + (SETQ G166922 + (CONS + (|htMakeTemplates,substLabel| + |i| |template|) + G166922))))))) + G166910)))))))))))) + +;templateParts template == +; NULL STRINGP template => template +; i := SEARCH('"%l", template) +; null i => template +; [SUBSEQ(template, 0, i), : SUBSEQ(template, i+2)] + +(DEFUN |templateParts| (|template|) + (PROG (|i|) + (RETURN + (COND + ((NULL (STRINGP |template|)) |template|) + ('T (SPADLET |i| (SEARCH (MAKESTRING "%l") |template|)) + (COND + ((NULL |i|) |template|) + ('T + (CONS (SUBSEQ |template| 0 |i|) + (SUBSEQ |template| (PLUS |i| 2)))))))))) + +;htMakeDoneButton(message, func) == +; bcHt '"\newline\vspace{1}\centerline{" +; if message = '"Continue" then +; bchtMakeButton('"\lispdownlink", "\ContinueBitmap", func) +; else +; bchtMakeButton('"\lispdownlink",CONCAT('"\box{", message, '"}"), func) +; bcHt '"} " + +(DEFUN |htMakeDoneButton| (|message| |func|) + (PROGN + (|bcHt| (MAKESTRING "\\newline\\vspace{1}\\centerline{")) + (COND + ((BOOT-EQUAL |message| (MAKESTRING "Continue")) + (|bchtMakeButton| (MAKESTRING "\\lispdownlink") + '|\\ContinueBitmap| |func|)) + ('T + (|bchtMakeButton| (MAKESTRING "\\lispdownlink") + (CONCAT (MAKESTRING "\\box{") |message| (MAKESTRING "}")) + |func|))) + (|bcHt| (MAKESTRING "} ")))) + +;htProcessDoneButton [label , func] == +; iht '"\newline\vspace{1}\centerline{" +; if label = '"Continue" then +; htMakeButton('"\lispdownlink", "\ContinueBitmap", func) +; else if label = '"Push to enter names" then +; htMakeButton('"\lispdownlink",'"\ControlBitmap{clicktoset}", func) +; else +; htMakeButton('"\lispdownlink", CONCAT('"\box{", label, '"}"), func) +; iht '"} " + +(DEFUN |htProcessDoneButton| (G166950) + (PROG (|label| |func|) + (RETURN + (PROGN + (SPADLET |label| (CAR G166950)) + (SPADLET |func| (CADR G166950)) + (|iht| (MAKESTRING "\\newline\\vspace{1}\\centerline{")) + (COND + ((BOOT-EQUAL |label| (MAKESTRING "Continue")) + (|htMakeButton| (MAKESTRING "\\lispdownlink") + '|\\ContinueBitmap| |func|)) + ((BOOT-EQUAL |label| (MAKESTRING "Push to enter names")) + (|htMakeButton| (MAKESTRING "\\lispdownlink") + (MAKESTRING "\\ControlBitmap{clicktoset}") |func|)) + ('T + (|htMakeButton| (MAKESTRING "\\lispdownlink") + (CONCAT (MAKESTRING "\\box{") |label| (MAKESTRING "}")) + |func|))) + (|iht| (MAKESTRING "} ")))))) + +;htMakeButton(htCommand, message, func,:options) == +;----------> OBSELETE <---------------------------------- +; skipStateInfo? := IFCAR options +; iht [htCommand, '"{"] +; bcIssueHt message +; skipStateInfo? => +; iht ['"}{(|htDoneButton| '|", func, '"| ",htpName $curPage, '")}"] +; iht ['"}{(|htDoneButton| '|", func, '"| (PROGN "] +; for [id, ., ., ., type, :.] in htpInputAreaAlist $curPage repeat +; iht ['"(|htpSetLabelInputString| ", htpName $curPage, '"'|", id, '"| "] +; if type = 'string then +; iht ['"_"\stringvalue{", id, '"}_""] +; else +; iht ['"_"\boxvalue{", id, '"}_""] +; iht '") " +; iht [htpName $curPage, '"))}"] + +(DEFUN |htMakeButton| + (&REST G166990 &AUX |options| |func| |message| |htCommand|) + (DSETQ (|htCommand| |message| |func| . |options|) G166990) + (PROG (|skipStateInfo?| |id| |type|) + (declare (special |$curPage|)) + (RETURN + (SEQ (PROGN + (SPADLET |skipStateInfo?| (IFCAR |options|)) + (|iht| (CONS |htCommand| (CONS (MAKESTRING "{") NIL))) + (|bcIssueHt| |message|) + (COND + (|skipStateInfo?| + (|iht| (CONS (MAKESTRING "}{(|htDoneButton| '|") + (CONS |func| + (CONS (MAKESTRING "| ") + (CONS (|htpName| |$curPage|) + (CONS (MAKESTRING ")}") NIL))))))) + ('T + (|iht| (CONS (MAKESTRING "}{(|htDoneButton| '|") + (CONS |func| + (CONS (MAKESTRING "| (PROGN ") NIL)))) + (DO ((G166977 (|htpInputAreaAlist| |$curPage|) + (CDR G166977)) + (G166965 NIL)) + ((OR (ATOM G166977) + (PROGN (SETQ G166965 (CAR G166977)) NIL) + (PROGN + (PROGN + (SPADLET |id| (CAR G166965)) + (SPADLET |type| (CAR (CDDDDR G166965))) + G166965) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|iht| (CONS + (MAKESTRING + "(|htpSetLabelInputString| ") + (CONS (|htpName| |$curPage|) + (CONS (MAKESTRING "'|") + (CONS |id| + (CONS (MAKESTRING "| ") NIL)))))) + (COND + ((BOOT-EQUAL |type| '|string|) + (|iht| (CONS + (MAKESTRING + "\"\\stringvalue{") + (CONS |id| + (CONS (MAKESTRING "}\"") + NIL))))) + ('T + (|iht| (CONS + (MAKESTRING "\"\\boxvalue{") + (CONS |id| + (CONS (MAKESTRING "}\"") + NIL)))))) + (|iht| (MAKESTRING ") ")))))) + (|iht| (CONS (|htpName| |$curPage|) + (CONS (MAKESTRING "))}") NIL)))))))))) + +;bchtMakeButton(htCommand, message, func) == +; bcHt [htCommand, '"{", message, +; '"}{(|htDoneButton| '|", func, '"| (PROGN "] +; for [id, ., ., ., type, :.] in htpInputAreaAlist $curPage repeat +; bcHt ['"(|htpSetLabelInputString| ", htpName $curPage, '"'|", id, '"| "] +; if type = 'string then +; bcHt ['"_"\stringvalue{", id, '"}_""] +; else +; bcHt ['"_"\boxvalue{", id, '"}_""] +; bcHt '") " +; bcHt [htpName $curPage, '"))} "] + +(DEFUN |bchtMakeButton| (|htCommand| |message| |func|) + (PROG (|id| |type|) + (declare (special |$curPage|)) + (RETURN + (SEQ (PROGN + (|bcHt| (CONS |htCommand| + (CONS (MAKESTRING "{") + (CONS |message| + (CONS + (MAKESTRING + "}{(|htDoneButton| '|") + (CONS |func| + (CONS (MAKESTRING "| (PROGN ") + NIL))))))) + (DO ((G167004 (|htpInputAreaAlist| |$curPage|) + (CDR G167004)) + (G166992 NIL)) + ((OR (ATOM G167004) + (PROGN (SETQ G166992 (CAR G167004)) NIL) + (PROGN + (PROGN + (SPADLET |id| (CAR G166992)) + (SPADLET |type| (CAR (CDDDDR G166992))) + G166992) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|bcHt| (CONS + (MAKESTRING + "(|htpSetLabelInputString| ") + (CONS (|htpName| |$curPage|) + (CONS (MAKESTRING "'|") + (CONS |id| + (CONS (MAKESTRING "| ") NIL)))))) + (COND + ((BOOT-EQUAL |type| '|string|) + (|bcHt| (CONS + (MAKESTRING "\"\\stringvalue{") + (CONS |id| + (CONS (MAKESTRING "}\"") NIL))))) + ('T + (|bcHt| (CONS + (MAKESTRING "\"\\boxvalue{") + (CONS |id| + (CONS (MAKESTRING "}\"") NIL)))))) + (|bcHt| (MAKESTRING ") ")))))) + (|bcHt| (CONS (|htpName| |$curPage|) + (CONS (MAKESTRING "))} ") NIL)))))))) + +;htProcessDoitButton [label, command, func] == +; fun := mkCurryFun(func, [command]) +; iht '"\newline\vspace{1}\centerline{" +; htMakeButton('"\lispcommand", CONCAT('"\box{", label, '"}"), fun) +; iht '"} " +; iht '"\vspace{2}{Select \ \UpButton{} \ to go back one page.}" +; iht '"\newline{Select \ \ExitButton{QuitPage} \ to remove this window.}" + +(DEFUN |htProcessDoitButton| (G167017) + (PROG (|label| |command| |func| |fun|) + (RETURN + (PROGN + (SPADLET |label| (CAR G167017)) + (SPADLET |command| (CADR G167017)) + (SPADLET |func| (CADDR G167017)) + (SPADLET |fun| (|mkCurryFun| |func| (CONS |command| NIL))) + (|iht| (MAKESTRING "\\newline\\vspace{1}\\centerline{")) + (|htMakeButton| (MAKESTRING "\\lispcommand") + (CONCAT (MAKESTRING "\\box{") |label| (MAKESTRING "}")) + |fun|) + (|iht| (MAKESTRING "} ")) + (|iht| (MAKESTRING + "\\vspace{2}{Select \\ \\UpButton{} \\ to go back one page.}")) + (|iht| (MAKESTRING +"\\newline{Select \\ \\ExitButton{QuitPage} \\ to remove this window.}")))))) + +;htMakeDoitButton(label, command) == +; -- use bitmap button if just plain old "Do It" +; if label = '"Do It" then +; bcHt '"\newline\vspace{1}\centerline{\lispcommand{\DoItBitmap}{(|doDoitButton| " +; else +; bcHt ['"\newline\vspace{1}\centerline{\lispcommand{\box{", label, +; '"}}{(|doDoitButton| "] +; bcHt htpName $curPage +; bcHt ['" _"", htEscapeString command, '"_""] +; bcHt '")}}" +; bcHt '"\vspace{2}{Select \ \UpButton{} \ to go back one page.}" +; bcHt '"\newline{Select \ \ExitButton{QuitPage} \ to remove this window.}" + +(DEFUN |htMakeDoitButton| (|label| |command|) + (declare (special |$curPage|)) + (PROGN + (COND + ((BOOT-EQUAL |label| (MAKESTRING "Do It")) + (|bcHt| (MAKESTRING +"\\newline\\vspace{1}\\centerline{\\lispcommand{\\DoItBitmap}{(|doDoitButton| "))) + ('T + (|bcHt| (CONS (MAKESTRING + "\\newline\\vspace{1}\\centerline{\\lispcommand{\\box{") + (CONS |label| + (CONS (MAKESTRING "}}{(|doDoitButton| ") + NIL)))))) + (|bcHt| (|htpName| |$curPage|)) + (|bcHt| (CONS (MAKESTRING " \"") + (CONS (|htEscapeString| |command|) + (CONS (MAKESTRING "\"") NIL)))) + (|bcHt| (MAKESTRING ")}}")) + (|bcHt| (MAKESTRING + "\\vspace{2}{Select \\ \\UpButton{} \\ to go back one page.}")) + (|bcHt| (MAKESTRING + "\\newline{Select \\ \\ExitButton{QuitPage} \\ to remove this window.}")))) + +;doDoitButton(htPage, command) == +; executeInterpreterCommand command + +(DEFUN |doDoitButton| (|htPage| |command|) + (declare (ignore |htPage|)) + (|executeInterpreterCommand| |command|)) + +;executeInterpreterCommand command == +; PRINC command +; TERPRI() +; ncSetCurrentLine(command) +; CATCH('SPAD__READER, parseAndInterpret command) +; PRINC MKPROMPT() +; FINISH_-OUTPUT() + +(DEFUN |executeInterpreterCommand| (|command|) + (PROGN + (PRINC |command|) + (TERPRI) + (|ncSetCurrentLine| |command|) + (CATCH 'SPAD_READER (|parseAndInterpret| |command|)) + (PRINC (MKPROMPT)) + (FINISH-OUTPUT))) + +;htDoneButton(func, htPage) == +; typeCheckInputAreas htPage => +; htMakeErrorPage htPage +; NULL FBOUNDP func => +; systemError ['"unknown function", func] +; FUNCALL(SYMBOL_-FUNCTION func, htPage) + +(DEFUN |htDoneButton| (|func| |htPage|) + (COND + ((|typeCheckInputAreas| |htPage|) (|htMakeErrorPage| |htPage|)) + ((NULL (FBOUNDP |func|)) + (|systemError| + (CONS (MAKESTRING "unknown function") (CONS |func| NIL)))) + ('T (FUNCALL (SYMBOL-FUNCTION |func|) |htPage|)))) + +;typeCheckInputAreas htPage == +; -- This needs to be severly beefed up +; inputAlist := nil +; errorCondition := false +; for entry in htpInputAreaAlist htPage +; | entry is [stringName, ., ., ., 'string, ., spadType, filter] repeat +; condList := +; LASSOC(LASSOC(spadType,htpDomainPvarSubstList htPage), +; htpDomainVariableAlist htPage) +; string := htpLabelFilteredInputString(htPage, stringName) +; $bcParseOnly => +; null ncParseFromString string => +; htpSetLabelErrorMsg(htPage, '"Syntax Error", '"Syntax Error") +; nil +; val := checkCondition(htpLabelInputString(htPage, stringName), +; string, condList) +; STRINGP val => +; errorCondition := true +; htpSetLabelErrorMsg(htPage, stringName, val) +; htpSetLabelSpadValue(htPage, stringName, val) +; errorCondition + +(DEFUN |typeCheckInputAreas| (|htPage|) + (PROG (|inputAlist| |stringName| |ISTMP#1| |ISTMP#2| |ISTMP#3| + |ISTMP#4| |ISTMP#5| |ISTMP#6| |spadType| |ISTMP#7| |filter| + |condList| |string| |val| |errorCondition|) + (declare (special |$bcParseOnly|)) + (RETURN + (SEQ (PROGN + (SPADLET |inputAlist| NIL) + (SPADLET |errorCondition| NIL) + (DO ((G167160 (|htpInputAreaAlist| |htPage|) + (CDR G167160)) + (|entry| NIL)) + ((OR (ATOM G167160) + (PROGN (SETQ |entry| (CAR G167160)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |entry|) + (PROGN + (SPADLET |stringName| + (QCAR |entry|)) + (SPADLET |ISTMP#1| (QCDR |entry|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCAR |ISTMP#4|) + '|string|) + (PROGN + (SPADLET |ISTMP#5| + (QCDR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (PROGN + (SPADLET |ISTMP#6| + (QCDR |ISTMP#5|)) + (AND + (PAIRP |ISTMP#6|) + (PROGN + (SPADLET + |spadType| + (QCAR |ISTMP#6|)) + (SPADLET + |ISTMP#7| + (QCDR |ISTMP#6|)) + (AND + (PAIRP + |ISTMP#7|) + (EQ + (QCDR + |ISTMP#7|) + NIL) + (PROGN + (SPADLET + |filter| + (QCAR + |ISTMP#7|)) + 'T)))))))))))))))) + (PROGN + (SPADLET |condList| + (LASSOC + (LASSOC |spadType| + (|htpDomainPvarSubstList| + |htPage|)) + (|htpDomainVariableAlist| + |htPage|))) + (SPADLET |string| + (|htpLabelFilteredInputString| + |htPage| |stringName|)) + (COND + (|$bcParseOnly| + (COND + ((NULL + (|ncParseFromString| |string|)) + (|htpSetLabelErrorMsg| |htPage| + (MAKESTRING "Syntax Error") + (MAKESTRING "Syntax Error"))) + ('T NIL))) + ('T + (SPADLET |val| + (|checkCondition| + (|htpLabelInputString| + |htPage| |stringName|) + |string| |condList|)) + (COND + ((STRINGP |val|) + (SPADLET |errorCondition| 'T) + (|htpSetLabelErrorMsg| |htPage| + |stringName| |val|)) + ('T + (|htpSetLabelSpadValue| |htPage| + |stringName| |val|))))))))))) + |errorCondition|))))) + +;checkCondition(s1, string, condList) == +; condList is [['Satisfies, pvar, pred]] => +; val := FUNCALL(pred, string) +; STRINGP val => val +; ['(String), :wrap s1] +; condList isnt [['isDomain, pvar, pattern]] => +; systemError '"currently invalid domain condition" +; pattern is '(String) => ['(String), :wrap s1] +; val := parseAndEval string +; STRINGP val => +; val = '"Syntax Error " => '"Error: Syntax Error " +; condErrorMsg pattern +; [type, : data] := val +; newType := CATCH('SPAD__READER, resolveTM(type, pattern)) +; null newType => +; condErrorMsg pattern +; coerceInt(val, newType) + +(DEFUN |checkCondition| (|s1| |string| |condList|) + (PROG (|pred| |ISTMP#1| |ISTMP#2| |pvar| |ISTMP#3| |pattern| |val| + |type| |data| |newType|) + (RETURN + (COND + ((AND (PAIRP |condList|) (EQ (QCDR |condList|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |condList|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Satisfies|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |pvar| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |pred| (QCAR |ISTMP#3|)) + 'T)))))))) + (SPADLET |val| (FUNCALL |pred| |string|)) + (COND + ((STRINGP |val|) |val|) + ('T (CONS '(|String|) (|wrap| |s1|))))) + ((NULL (AND (PAIRP |condList|) (EQ (QCDR |condList|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |condList|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|isDomain|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |pvar| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |pattern| + (QCAR |ISTMP#3|)) + 'T))))))))) + (|systemError| + (MAKESTRING "currently invalid domain condition"))) + ((EQUAL |pattern| '(|String|)) + (CONS '(|String|) (|wrap| |s1|))) + ('T (SPADLET |val| (|parseAndEval| |string|)) + (COND + ((STRINGP |val|) + (COND + ((BOOT-EQUAL |val| (MAKESTRING "Syntax Error ")) + (MAKESTRING "Error: Syntax Error ")) + ('T (|condErrorMsg| |pattern|)))) + ('T (SPADLET |type| (CAR |val|)) + (SPADLET |data| (CDR |val|)) + (SPADLET |newType| + (CATCH 'SPAD_READER + (|resolveTM| |type| |pattern|))) + (COND + ((NULL |newType|) (|condErrorMsg| |pattern|)) + ('T (|coerceInt| |val| |newType|)))))))))) + +;condErrorMsg type == +; typeString := form2String type +; if PAIRP typeString then typeString := APPLY(function CONCAT, typeString) +; CONCAT('"Error: Could not make your input into a ", typeString) + +(DEFUN |condErrorMsg| (|type|) + (PROG (|typeString|) + (RETURN + (PROGN + (SPADLET |typeString| (|form2String| |type|)) + (COND + ((PAIRP |typeString|) + (SPADLET |typeString| + (APPLY (|function| CONCAT) |typeString|)))) + (CONCAT (MAKESTRING "Error: Could not make your input into a ") + |typeString|))))) + +;parseAndEval string == +; $InteractiveMode :fluid := true +; $BOOT: fluid := NIL +; $SPAD: fluid := true +; $e:fluid := $InteractiveFrame +; $QuietCommand:local := true +; parseAndEval1 string + +(DEFUN |parseAndEval| (|string|) + (PROG (|$InteractiveMode| $BOOT $SPAD |$e| |$QuietCommand|) + (DECLARE (SPECIAL |$InteractiveMode| $BOOT $SPAD |$e| + |$QuietCommand|)) + (RETURN + (PROGN + (SPADLET |$InteractiveMode| 'T) + (SPADLET $BOOT NIL) + (SPADLET $SPAD 'T) + (SPADLET |$e| |$InteractiveFrame|) + (SPADLET |$QuietCommand| 'T) + (|parseAndEval1| |string|))))) + +;parseAndEval1 string == +; syntaxError := false +; pform := +; $useNewParser => +; v := applyWithOutputToString('ncParseFromString, [string]) +; CAR v => CAR v +; syntaxError := true +; CDR v +; oldParseString string +; syntaxError => +; '"Syntax Error " +; pform => +; val := applyWithOutputToString('processInteractive, [pform, nil]) +; CAR val => CAR val +; '"Type Analysis Error" +; nil + +(DEFUN |parseAndEval1| (|string|) + (PROG (|v| |syntaxError| |pform| |val|) + (declare (special |$useNewParser|)) + (RETURN + (PROGN + (SPADLET |syntaxError| NIL) + (SPADLET |pform| + (COND + (|$useNewParser| + (SPADLET |v| + (|applyWithOutputToString| + '|ncParseFromString| + (CONS |string| NIL))) + (COND + ((CAR |v|) (CAR |v|)) + ('T (SPADLET |syntaxError| 'T) (CDR |v|)))) + ('T (|oldParseString| |string|)))) + (COND + (|syntaxError| (MAKESTRING "Syntax Error ")) + (|pform| (SPADLET |val| + (|applyWithOutputToString| + '|processInteractive| + (CONS |pform| (CONS NIL NIL)))) + (COND + ((CAR |val|) (CAR |val|)) + ('T (MAKESTRING "Type Analysis Error")))) + ('T NIL)))))) + +;oldParseString string == +; tree := applyWithOutputToString('string2SpadTree, [string]) +; CAR tree => parseTransform postTransform CAR tree +; CDR tree + +(DEFUN |oldParseString| (|string|) + (PROG (|tree|) + (RETURN + (PROGN + (SPADLET |tree| + (|applyWithOutputToString| '|string2SpadTree| + (CONS |string| NIL))) + (COND + ((CAR |tree|) + (|parseTransform| (|postTransform| (CAR |tree|)))) + ('T (CDR |tree|))))))) + +;makeSpadCommand(:l) == +; opForm := CONCAT(first l, '"(") +; lastArg := last l +; l := rest l +; argList := nil +; for arg in l while arg ^= lastArg repeat +; argList := [CONCAT(arg, '", "), :argList] +; argList := nreverse [lastArg, :argList] +; CONCAT(opForm, APPLY(function CONCAT, argList), '")") + +(DEFUN |makeSpadCommand| (&REST G167322 &AUX |l|) + (DSETQ |l| G167322) + (PROG (|opForm| |lastArg| |argList|) + (RETURN + (SEQ (PROGN + (SPADLET |opForm| (CONCAT (CAR |l|) (MAKESTRING "("))) + (SPADLET |lastArg| (|last| |l|)) + (SPADLET |l| (CDR |l|)) + (SPADLET |argList| NIL) + (DO ((G167306 |l| (CDR G167306)) (|arg| NIL)) + ((OR (ATOM G167306) + (PROGN (SETQ |arg| (CAR G167306)) NIL) + (NULL (NEQUAL |arg| |lastArg|))) + NIL) + (SEQ (EXIT (SPADLET |argList| + (CONS + (CONCAT |arg| (MAKESTRING ", ")) + |argList|))))) + (SPADLET |argList| (NREVERSE (CONS |lastArg| |argList|))) + (CONCAT |opForm| (APPLY (|function| CONCAT) |argList|) + (MAKESTRING ")"))))))) + +;htMakeInputList stringList == +;-- makes an input form for constructing a list +; lastArg := last stringList +; argList := nil +; for arg in stringList while arg ^= lastArg repeat +; argList := [CONCAT(arg, '", "), :argList] +; argList := nreverse [lastArg, :argList] +; bracketString APPLY(function CONCAT, argList) + +(DEFUN |htMakeInputList| (|stringList|) + (PROG (|lastArg| |argList|) + (RETURN + (SEQ (PROGN + (SPADLET |lastArg| (|last| |stringList|)) + (SPADLET |argList| NIL) + (DO ((G167328 |stringList| (CDR G167328)) (|arg| NIL)) + ((OR (ATOM G167328) + (PROGN (SETQ |arg| (CAR G167328)) NIL) + (NULL (NEQUAL |arg| |lastArg|))) + NIL) + (SEQ (EXIT (SPADLET |argList| + (CONS + (CONCAT |arg| (MAKESTRING ", ")) + |argList|))))) + (SPADLET |argList| (NREVERSE (CONS |lastArg| |argList|))) + (|bracketString| (APPLY (|function| CONCAT) |argList|))))))) + +;-- predefined filter strings +;bracketString string == CONCAT('"[",string,'"]") + +(DEFUN |bracketString| (|string|) + (CONCAT (MAKESTRING "[") |string| (MAKESTRING "]"))) + +;quoteString string == CONCAT('"_"", string, '"_"") + +(DEFUN |quoteString| (|string|) + (CONCAT (MAKESTRING "\"") |string| (MAKESTRING "\""))) + +;$funnyQuote := char 127 + +(SPADLET |$funnyQuote| (|char| 127)) + +;$funnyBacks := char 128 + +(SPADLET |$funnyBacks| (|char| 128)) + +;htEscapeString str == +; str := SUBSTITUTE($funnyQuote, char '_", str) +; SUBSTITUTE($funnyBacks, char '_\, str) + +(DEFUN |htEscapeString| (|str|) + (declare (special |$funnyBacks| |$funnyQuote|)) + (PROGN + (SPADLET |str| (SUBSTITUTE |$funnyQuote| (|char| '|"|) |str|)) + (SUBSTITUTE |$funnyBacks| (|char| '|\\|) |str|))) + +;unescapeStringsInForm form == +; STRINGP form => +; str := NSUBSTITUTE(char '_", $funnyQuote, form) +; NSUBSTITUTE(char '_\, $funnyBacks, str) +; CONSP form => +; unescapeStringsInForm CAR form +; unescapeStringsInForm CDR form +; form +; form + +(DEFUN |unescapeStringsInForm| (|form|) + (PROG (|str|) + (declare (special |$funnyBacks| |$funnyQuote|)) + (RETURN + (COND + ((STRINGP |form|) + (SPADLET |str| + (NSUBSTITUTE (|char| '|"|) |$funnyQuote| |form|)) + (NSUBSTITUTE (|char| '|\\|) |$funnyBacks| |str|)) + ((CONSP |form|) (|unescapeStringsInForm| (CAR |form|)) + (|unescapeStringsInForm| (CDR |form|)) |form|) + ('T |form|))))) + +;htsv() == +; startHTPage(50) +; htSetVars() + +(DEFUN |htsv| () (PROGN (|startHTPage| 50) (|htSetVars|))) + +;htSetVars() == +; $path := nil +; $lastTree := nil +; if 0 ^= LASTATOM $setOptions then htMarkTree($setOptions,0) +; htShowSetTree($setOptions) + +(DEFUN |htSetVars| () + (declare (special |$setOptions| |$lastTree| |$path|)) + (PROGN + (SPADLET |$path| NIL) + (SPADLET |$lastTree| NIL) + (COND + ((NEQUAL 0 (LASTATOM |$setOptions|)) + (|htMarkTree| |$setOptions| 0))) + (|htShowSetTree| |$setOptions|))) + +;htShowSetTree(setTree) == +; $path := TAKE(- LASTATOM setTree,$path) +; page := htInitPage(mkSetTitle(),nil) +; htpSetProperty(page, 'setTree, setTree) +; links := nil +; maxWidth1 := maxWidth2 := 0 +; for setData in setTree repeat +; satisfiesUserLevel setData.setLevel => +; okList := [setData,:okList] +; maxWidth1 := MAX(# PNAME setData.setName,maxWidth1) +; maxWidth2 := MAX(htShowCount STRINGIMAGE setData.setLabel,maxWidth2) +; maxWidth1 := MAX(9,maxWidth1) +; maxWidth2 := MAX(41,maxWidth2) +; tabset1 := STRINGIMAGE (maxWidth1) +; tabset2 := STRINGIMAGE (maxWidth2 + maxWidth1 - 1) +; htSay('"\tab{2}\newline Variable\tab{",STRINGIMAGE (maxWidth1 + (maxWidth2/3)),'"}Description\tab{",STRINGIMAGE(maxWidth2 + maxWidth1 + 2),'"}Value\newline\beginitems ") +; for setData in REVERSE okList repeat +; htSay '"\item" +; label := STRCONC('"\menuitemstyle{",setData.setName,'"}") +; links := [label,[['text,'"\tab{",tabset1,'"}",setData.setLabel,'"\tab{",tabset2,'"}{\em ",htShowSetTreeValue setData,'"}"]], +; 'htShowSetPage, setData.setName] +; htMakePage [['bcLispLinks, links,'options,'(indent . 0)]] +; htSay '"\enditems" +; htShowPage() + +(DEFUN |htShowSetTree| (|setTree|) + (PROG (|page| |okList| |maxWidth1| |maxWidth2| |tabset1| |tabset2| + |label| |links|) + (declare (special |$path|)) + (RETURN + (SEQ (PROGN + (SPADLET |$path| + (TAKE (SPADDIFFERENCE (LASTATOM |setTree|)) + |$path|)) + (SPADLET |page| (|htInitPage| (|mkSetTitle|) NIL)) + (|htpSetProperty| |page| '|setTree| |setTree|) + (SPADLET |links| NIL) + (SPADLET |maxWidth1| (SPADLET |maxWidth2| 0)) + (SEQ (DO ((G167379 |setTree| (CDR G167379)) + (|setData| NIL)) + ((OR (ATOM G167379) + (PROGN + (SETQ |setData| (CAR G167379)) + NIL)) + NIL) + (SEQ (EXIT (COND + ((|satisfiesUserLevel| + (ELT |setData| 2)) + (EXIT (PROGN + (SPADLET |okList| + (CONS |setData| |okList|)) + (SPADLET |maxWidth1| + (MAX + (|#| + (PNAME (ELT |setData| 0))) + |maxWidth1|)) + (SPADLET |maxWidth2| + (MAX + (|htShowCount| + (STRINGIMAGE + (ELT |setData| 1))) + |maxWidth2|))))))))) + (SPADLET |maxWidth1| (MAX 9 |maxWidth1|)) + (SPADLET |maxWidth2| (MAX 41 |maxWidth2|)) + (SPADLET |tabset1| (STRINGIMAGE |maxWidth1|)) + (SPADLET |tabset2| + (STRINGIMAGE + (SPADDIFFERENCE + (PLUS |maxWidth2| |maxWidth1|) 1))) + (|htSay| (MAKESTRING + "\\tab{2}\\newline Variable\\tab{") + (STRINGIMAGE + (PLUS |maxWidth1| + (QUOTIENT |maxWidth2| 3))) + (MAKESTRING "}Description\\tab{") + (STRINGIMAGE + (PLUS (PLUS |maxWidth2| |maxWidth1|) 2)) + (MAKESTRING "}Value\\newline\\beginitems ")) + (DO ((G167392 (REVERSE |okList|) (CDR G167392)) + (|setData| NIL)) + ((OR (ATOM G167392) + (PROGN + (SETQ |setData| (CAR G167392)) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|htSay| (MAKESTRING "\\item")) + (SPADLET |label| + (STRCONC + (MAKESTRING + "\\menuitemstyle{") + (ELT |setData| 0) + (MAKESTRING "}"))) + (SPADLET |links| + (CONS |label| + (CONS + (CONS + (CONS '|text| + (CONS + (MAKESTRING "\\tab{") + (CONS |tabset1| + (CONS (MAKESTRING "}") + (CONS + (ELT |setData| 1) + (CONS + (MAKESTRING + "\\tab{") + (CONS |tabset2| + (CONS + (MAKESTRING + "}{\\em ") + (CONS + (|htShowSetTreeValue| + |setData|) + (CONS + (MAKESTRING "}") + NIL)))))))))) + NIL) + (CONS '|htShowSetPage| + (CONS (ELT |setData| 0) + NIL))))) + (|htMakePage| + (CONS + (CONS '|bcLispLinks| + (CONS |links| + (CONS '|options| + (CONS '(|indent| . 0) NIL)))) + NIL)))))) + (|htSay| (MAKESTRING "\\enditems")) (|htShowPage|))))))) + +;htShowCount s == --# discounting {\em .. } +; m := #s +; m < 8 => m - 1 +; i := 0 +; count := 0 +; while i < m - 7 repeat +; s.i = char '_{ and s.(i+1) = char '_\ and s.(i+2) = char 'e +; and s.(i+3) = char 'm => i := i + 6 --discount {\em } +; i := i + 1 +; count := count + 1 +; count + (m - i) + +(DEFUN |htShowCount| (|s|) + (PROG (|m| |i| |count|) + (RETURN + (SEQ (PROGN + (SPADLET |m| (|#| |s|)) + (COND + ((> 8 |m|) (SPADDIFFERENCE |m| 1)) + ('T (SPADLET |i| 0) (SPADLET |count| 0) + (DO () ((NULL (> (SPADDIFFERENCE |m| 7) |i|)) NIL) + (SEQ (EXIT (COND + ((AND (BOOT-EQUAL (ELT |s| |i|) + (|char| '{)) + (BOOT-EQUAL (ELT |s| (PLUS |i| 1)) + (|char| '|\\|)) + (BOOT-EQUAL (ELT |s| (PLUS |i| 2)) + (|char| '|e|)) + (BOOT-EQUAL (ELT |s| (PLUS |i| 3)) + (|char| '|m|))) + (SPADLET |i| (PLUS |i| 6))) + ('T (SPADLET |i| (PLUS |i| 1)) + (SPADLET |count| (PLUS |count| 1))))))) + (PLUS |count| (SPADDIFFERENCE |m| |i|))))))))) + +;htShowSetTreeValue(setData) == +; st := setData.setType +; st = 'FUNCTION => object2String FUNCALL(setData.setVar,"%display%") +; st = 'INTEGER => object2String eval setData.setVar +; st = 'STRING => object2String eval setData.setVar +; st = 'LITERALS => +; object2String translateTrueFalse2YesNo eval setData.setVar +; st = 'TREE => '"..." +; systemError() + +(DEFUN |htShowSetTreeValue| (|setData|) + (PROG (|st|) + (RETURN + (PROGN + (SPADLET |st| (ELT |setData| 3)) + (COND + ((BOOT-EQUAL |st| 'FUNCTION) + (|object2String| (FUNCALL (ELT |setData| 4) '|%display%|))) + ((BOOT-EQUAL |st| 'INTEGER) + (|object2String| (|eval| (ELT |setData| 4)))) + ((BOOT-EQUAL |st| 'STRING) + (|object2String| (|eval| (ELT |setData| 4)))) + ((BOOT-EQUAL |st| 'LITERALS) + (|object2String| + (|translateTrueFalse2YesNo| (|eval| (ELT |setData| 4))))) + ((BOOT-EQUAL |st| 'TREE) (MAKESTRING "...")) + ('T (|systemError|))))))) + +;mkSetTitle() == STRCONC('"Command {\em )set ",listOfStrings2String $path,'"}") + +(DEFUN |mkSetTitle| () + (declare (special |$path|)) + (STRCONC (MAKESTRING "Command {\\em )set ") + (|listOfStrings2String| |$path|) (MAKESTRING "}"))) + +;listOfStrings2String u == +; null u => '"" +; STRCONC(listOfStrings2String rest u,'" ",stringize first u) + +(DEFUN |listOfStrings2String| (|u|) + (COND + ((NULL |u|) (MAKESTRING "")) + ('T + (STRCONC (|listOfStrings2String| (CDR |u|)) (MAKESTRING " ") + (|stringize| (CAR |u|)))))) + +;htShowSetPage(htPage, branch) == +; setTree := htpProperty(htPage, 'setTree) +; $path := [branch,:TAKE(- LASTATOM setTree,$path)] +; setData := ASSOC(branch, setTree) +; null setData => +; systemError('"No Set Data") +; st := setData.setType +; st = 'FUNCTION => htShowFunctionPage(htPage, setData) +; st = 'INTEGER => htShowIntegerPage(htPage,setData) +; st = 'LITERALS => htShowLiteralsPage(htPage, setData) +; st = 'TREE => htShowSetTree(setData.setLeaf) +; st = 'STRING => -- have to add this +; htSetNotAvailable(htPage,'")set compiler") +; systemError '"Unknown data type" + +(DEFUN |htShowSetPage| (|htPage| |branch|) + (PROG (|setTree| |setData| |st|) + (declare (special |$path|)) + (RETURN + (PROGN + (SPADLET |setTree| (|htpProperty| |htPage| '|setTree|)) + (SPADLET |$path| + (CONS |branch| + (TAKE (SPADDIFFERENCE (LASTATOM |setTree|)) + |$path|))) + (SPADLET |setData| (|assoc| |branch| |setTree|)) + (COND + ((NULL |setData|) (|systemError| (MAKESTRING "No Set Data"))) + ('T (SPADLET |st| (ELT |setData| 3)) + (COND + ((BOOT-EQUAL |st| 'FUNCTION) + (|htShowFunctionPage| |htPage| |setData|)) + ((BOOT-EQUAL |st| 'INTEGER) + (|htShowIntegerPage| |htPage| |setData|)) + ((BOOT-EQUAL |st| 'LITERALS) + (|htShowLiteralsPage| |htPage| |setData|)) + ((BOOT-EQUAL |st| 'TREE) + (|htShowSetTree| (ELT |setData| 5))) + ((BOOT-EQUAL |st| 'STRING) + (|htSetNotAvailable| |htPage| + (MAKESTRING ")set compiler"))) + ('T (|systemError| (MAKESTRING "Unknown data type")))))))))) + +;htShowLiteralsPage(htPage, setData) == +; htSetLiterals(htPage,setData.setName,setData.setLabel, +; setData.setVar,setData.setLeaf,'htSetLiteral) + +(DEFUN |htShowLiteralsPage| (|htPage| |setData|) + (|htSetLiterals| |htPage| (ELT |setData| 0) (ELT |setData| 1) + (ELT |setData| 4) (ELT |setData| 5) '|htSetLiteral|)) + +;htSetLiterals(htPage,name,message,variable,values,functionToCall) == +; page := htInitPage('"Set Command", htpPropertyList htPage) +; htpSetProperty(page, 'variable, variable) +; bcHt ['"\centerline{Set {\em ", name, '"}}\newline"] +; bcHt ['"{\em Description: } ", message, '"\newline\vspace{1} "] +; bcHt '"Select one of the following: \newline\tab{3} " +; links := [[STRCONC('"",STRINGIMAGE opt), '"\newline\tab{3}", functionToCall, opt] for opt in values] +; htMakePage [['bcLispLinks, :links]] +; bcHt ["\indent{0}\newline\vspace{1} The current setting is: {\em ", +; translateTrueFalse2YesNo EVAL variable, '"} "] +; htShowPage() + +(DEFUN |htSetLiterals| + (|htPage| |name| |message| |variable| |values| |functionToCall|) + (PROG (|page| |links|) + (RETURN + (SEQ (PROGN + (SPADLET |page| + (|htInitPage| (MAKESTRING "Set Command") + (|htpPropertyList| |htPage|))) + (|htpSetProperty| |page| '|variable| |variable|) + (|bcHt| (CONS (MAKESTRING "\\centerline{Set {\\em ") + (CONS |name| + (CONS (MAKESTRING "}}\\newline") NIL)))) + (|bcHt| (CONS (MAKESTRING "{\\em Description: } ") + (CONS |message| + (CONS (MAKESTRING + "\\newline\\vspace{1} ") + NIL)))) + (|bcHt| (MAKESTRING + "Select one of the following: \\newline\\tab{3} ")) + (SPADLET |links| + (PROG (G167460) + (SPADLET G167460 NIL) + (RETURN + (DO ((G167465 |values| (CDR G167465)) + (|opt| NIL)) + ((OR (ATOM G167465) + (PROGN + (SETQ |opt| (CAR G167465)) + NIL)) + (NREVERSE0 G167460)) + (SEQ (EXIT (SETQ G167460 + (CONS + (CONS + (STRCONC (MAKESTRING "") + (STRINGIMAGE |opt|)) + (CONS + (MAKESTRING + "\\newline\\tab{3}") + (CONS |functionToCall| + (CONS |opt| NIL)))) + G167460)))))))) + (|htMakePage| (CONS (CONS '|bcLispLinks| |links|) NIL)) + (|bcHt| + (CONS + '|\\indent{0}\\newline\\vspace{1} The current setting is: {\\em | + (CONS (|translateTrueFalse2YesNo| + (EVAL |variable|)) + (CONS (MAKESTRING "} ") NIL)))) + (|htShowPage|)))))) + +;htSetLiteral(htPage, val) == +; htInitPage('"Set Command", nil) +; SET(htpProperty(htPage, 'variable), translateYesNo2TrueFalse val) +; htKill(htPage,val) + +(DEFUN |htSetLiteral| (|htPage| |val|) + (PROGN + (|htInitPage| (MAKESTRING "Set Command") NIL) + (SET (|htpProperty| |htPage| '|variable|) + (|translateYesNo2TrueFalse| |val|)) + (|htKill| |htPage| |val|))) + +;htShowIntegerPage(htPage, setData) == +; page := htInitPage(mkSetTitle(), htpPropertyList htPage) +; htpSetProperty(page, 'variable, setData.setVar) +; bcHt ['"\centerline{Set {\em ", setData.setName, '"}}\newline"] +;-- message := isKeyedMsgInDb($path,'(setvar text A)) or setData.setLabel +; message := setData.setLabel +; bcHt ['"{\em Description: } ", message, '"\newline\vspace{1} "] +; [$htInitial,$htFinal] := setData.setLeaf +; if $htFinal = $htInitial + 1 +; then +; bcHt '"Enter the integer {\em " +; bcHt stringize $htInitial +; bcHt '"} or {\em " +; bcHt stringize $htFinal +; bcHt '"}:" +; else if null $htFinal then +; bcHt '"Enter an integer greater than {\em " +; bcHt stringize ($htInitial - 1) +; bcHt '"}:" +; else +; bcHt '"Enter an integer between {\em " +; bcHt stringize $htInitial +; bcHt '"} and {\em " +; bcHt stringize $htFinal +; bcHt '"}:" +; htMakePage [ +; '(domainConditions (Satisfies S chkRange)), +; ['bcStrings,[5,eval setData.setVar,'value,'S]]] +; htSetvarDoneButton('"Select to Set Value",'htSetInteger) +; htShowPage() + +(DEFUN |htShowIntegerPage| (|htPage| |setData|) + (PROG (|page| |message| |LETTMP#1|) + (declare (special |$htFinal| |$htInitial|)) + (RETURN + (PROGN + (SPADLET |page| + (|htInitPage| (|mkSetTitle|) + (|htpPropertyList| |htPage|))) + (|htpSetProperty| |page| '|variable| (ELT |setData| 4)) + (|bcHt| (CONS (MAKESTRING "\\centerline{Set {\\em ") + (CONS (ELT |setData| 0) + (CONS (MAKESTRING "}}\\newline") NIL)))) + (SPADLET |message| (ELT |setData| 1)) + (|bcHt| (CONS (MAKESTRING "{\\em Description: } ") + (CONS |message| + (CONS (MAKESTRING "\\newline\\vspace{1} ") + NIL)))) + (SPADLET |LETTMP#1| (ELT |setData| 5)) + (SPADLET |$htInitial| (CAR |LETTMP#1|)) + (SPADLET |$htFinal| (CADR |LETTMP#1|)) + (COND + ((BOOT-EQUAL |$htFinal| (PLUS |$htInitial| 1)) + (|bcHt| (MAKESTRING "Enter the integer {\\em ")) + (|bcHt| (|stringize| |$htInitial|)) + (|bcHt| (MAKESTRING "} or {\\em ")) + (|bcHt| (|stringize| |$htFinal|)) + (|bcHt| (MAKESTRING "}:"))) + ((NULL |$htFinal|) + (|bcHt| (MAKESTRING "Enter an integer greater than {\\em ")) + (|bcHt| (|stringize| (SPADDIFFERENCE |$htInitial| 1))) + (|bcHt| (MAKESTRING "}:"))) + ('T (|bcHt| (MAKESTRING "Enter an integer between {\\em ")) + (|bcHt| (|stringize| |$htInitial|)) + (|bcHt| (MAKESTRING "} and {\\em ")) + (|bcHt| (|stringize| |$htFinal|)) + (|bcHt| (MAKESTRING "}:")))) + (|htMakePage| + (CONS '(|domainConditions| (|Satisfies| S |chkRange|)) + (CONS (CONS '|bcStrings| + (CONS (CONS 5 + (CONS (|eval| (ELT |setData| 4)) + (CONS '|value| (CONS 'S NIL)))) + NIL)) + NIL))) + (|htSetvarDoneButton| (MAKESTRING "Select to Set Value") + '|htSetInteger|) + (|htShowPage|))))) + +;htSetInteger(htPage) == +; htInitPage(mkSetTitle(), nil) +; val := chkRange htpLabelInputString(htPage,'value) +; not INTEGERP val => +; errorPage(htPage,['"Value Error",nil,'"\vspace{3}\centerline{{\em ",val,'"}}\vspace{2}\newline\centerline{Click on \UpBitmap{} to re-enter value}"]) +; SET(htpProperty(htPage, 'variable), val) +; htKill(htPage,val) + +(DEFUN |htSetInteger| (|htPage|) + (PROG (|val|) + (RETURN + (PROGN + (|htInitPage| (|mkSetTitle|) NIL) + (SPADLET |val| + (|chkRange| (|htpLabelInputString| |htPage| '|value|))) + (COND + ((NULL (INTEGERP |val|)) + (|errorPage| |htPage| + (CONS (MAKESTRING "Value Error") + (CONS NIL + (CONS (MAKESTRING + "\\vspace{3}\\centerline{{\\em ") + (CONS |val| + (CONS + (MAKESTRING + "}}\\vspace{2}\\newline\\centerline{Click on \\UpBitmap{} to re-enter value}") + NIL))))))) + ('T (SET (|htpProperty| |htPage| '|variable|) |val|) + (|htKill| |htPage| |val|))))))) + +;htShowFunctionPage(htPage,setData) == +; fn := setData.setDef => FUNCALL(fn,htPage) +; htpSetProperty(htPage,'setData,setData) +; htpSetProperty(htPage,'parts, setData.setLeaf) +; htShowFunctionPageContinued(htPage) + +(DEFUN |htShowFunctionPage| (|htPage| |setData|) + (PROG (|fn|) + (RETURN + (COND + ((SPADLET |fn| (ELT |setData| 6)) (FUNCALL |fn| |htPage|)) + ('T (|htpSetProperty| |htPage| '|setData| |setData|) + (|htpSetProperty| |htPage| '|parts| (ELT |setData| 5)) + (|htShowFunctionPageContinued| |htPage|)))))) + +;htShowFunctionPageContinued(htPage) == +; parts := htpProperty(htPage,'parts) +; setData := htpProperty(htPage,'setData) +; [[phrase,kind,variable,checker,initValue,:.],:restParts] := parts +; htpSetProperty(htPage, 'variable, variable) +; htpSetProperty(htPage, 'checker, checker) +; htpSetProperty(htPage, 'parts, restParts) +; kind = 'LITERALS => htSetLiterals(htPage,setData.setName, +; phrase,variable,checker,'htFunctionSetLiteral) +; page := htInitPage(mkSetTitle(), htpPropertyList htPage) +; bcHt ['"\centerline{Set {\em ", setData.setName, '"}}\newline"] +; bcHt ['"{\em Description: } ", setData.setLabel, '"\newline\vspace{1} "] +; currentValue := EVAL variable +; htMakePage +; [ ['domainConditions, ['Satisfies,'S,checker]], +; ['text,:phrase], +; ['inputStrings, +; [ '"", '"", 60, currentValue, 'value, 'S]]] +; htSetvarDoneButton('"Select To Set Value",'htSetFunCommand) +; htShowPage() + +(DEFUN |htShowFunctionPageContinued| (|htPage|) + (PROG (|parts| |setData| |phrase| |kind| |variable| |checker| + |initValue| |restParts| |page| |currentValue|) + (RETURN + (PROGN + (SPADLET |parts| (|htpProperty| |htPage| '|parts|)) + (SPADLET |setData| (|htpProperty| |htPage| '|setData|)) + (SPADLET |phrase| (CAAR |parts|)) + (SPADLET |kind| (CADAR |parts|)) + (SPADLET |variable| (CADDAR |parts|)) + (SPADLET |checker| (CAR (CDDDAR |parts|))) + (SPADLET |initValue| (CADR (CDDDAR |parts|))) + (SPADLET |restParts| (CDR |parts|)) + (|htpSetProperty| |htPage| '|variable| |variable|) + (|htpSetProperty| |htPage| '|checker| |checker|) + (|htpSetProperty| |htPage| '|parts| |restParts|) + (COND + ((BOOT-EQUAL |kind| 'LITERALS) + (|htSetLiterals| |htPage| (ELT |setData| 0) |phrase| + |variable| |checker| '|htFunctionSetLiteral|)) + ('T + (SPADLET |page| + (|htInitPage| (|mkSetTitle|) + (|htpPropertyList| |htPage|))) + (|bcHt| (CONS (MAKESTRING "\\centerline{Set {\\em ") + (CONS (ELT |setData| 0) + (CONS (MAKESTRING "}}\\newline") NIL)))) + (|bcHt| (CONS (MAKESTRING "{\\em Description: } ") + (CONS (ELT |setData| 1) + (CONS (MAKESTRING + "\\newline\\vspace{1} ") + NIL)))) + (SPADLET |currentValue| (EVAL |variable|)) + (|htMakePage| + (CONS (CONS '|domainConditions| + (CONS (CONS '|Satisfies| + (CONS 'S (CONS |checker| NIL))) + NIL)) + (CONS (CONS '|text| |phrase|) + (CONS (CONS '|inputStrings| + (CONS + (CONS (MAKESTRING "") + (CONS (MAKESTRING "") + (CONS 60 + (CONS |currentValue| + (CONS '|value| + (CONS 'S NIL)))))) + NIL)) + NIL)))) + (|htSetvarDoneButton| (MAKESTRING "Select To Set Value") + '|htSetFunCommand|) + (|htShowPage|))))))) + +;htSetvarDoneButton(message, func) == +; bcHt '"\newline\vspace{1}\centerline{" +; if message = '"Select to Set Value" or message = '"Select to Set Values" then +; bchtMakeButton('"\lisplink",'"\ControlBitmap{clicktoset}", func) +; else +; bchtMakeButton('"\lisplink",CONCAT('"\fbox{", message, '"}"), func) +; bcHt '"} " + +(DEFUN |htSetvarDoneButton| (|message| |func|) + (PROGN + (|bcHt| (MAKESTRING "\\newline\\vspace{1}\\centerline{")) + (COND + ((OR (BOOT-EQUAL |message| (MAKESTRING "Select to Set Value")) + (BOOT-EQUAL |message| (MAKESTRING "Select to Set Values"))) + (|bchtMakeButton| (MAKESTRING "\\lisplink") + (MAKESTRING "\\ControlBitmap{clicktoset}") |func|)) + ('T + (|bchtMakeButton| (MAKESTRING "\\lisplink") + (CONCAT (MAKESTRING "\\fbox{") |message| (MAKESTRING "}")) + |func|))) + (|bcHt| (MAKESTRING "} ")))) + +;htFunctionSetLiteral(htPage, val) == +; htInitPage('"Set Command", nil) +; SET(htpProperty(htPage, 'variable), translateYesNo2TrueFalse val) +; htSetFunCommandContinue(htPage,val) + +(DEFUN |htFunctionSetLiteral| (|htPage| |val|) + (PROGN + (|htInitPage| (MAKESTRING "Set Command") NIL) + (SET (|htpProperty| |htPage| '|variable|) + (|translateYesNo2TrueFalse| |val|)) + (|htSetFunCommandContinue| |htPage| |val|))) + +;htSetFunCommand(htPage) == +; variable := htpProperty(htPage,'variable) +; checker := htpProperty(htPage,'checker) +; value := htCheck(checker,htpLabelInputString(htPage,'value)) +; SET(variable,value) --kill this later +; htSetFunCommandContinue(htPage,value) + +(DEFUN |htSetFunCommand| (|htPage|) + (PROG (|variable| |checker| |value|) + (RETURN + (PROGN + (SPADLET |variable| (|htpProperty| |htPage| '|variable|)) + (SPADLET |checker| (|htpProperty| |htPage| '|checker|)) + (SPADLET |value| + (|htCheck| |checker| + (|htpLabelInputString| |htPage| '|value|))) + (SET |variable| |value|) + (|htSetFunCommandContinue| |htPage| |value|))))) + +;htSetFunCommandContinue(htPage,value) == +; parts := htpProperty(htPage,'parts) +; continue := +; null parts => false +; parts is [['break,predicate],:restParts] => eval predicate +; true +; continue => +; htpSetProperty(htPage,'parts,restParts) +; htShowFunctionPageContinued(htPage) +; htKill(htPage,value) + +(DEFUN |htSetFunCommandContinue| (|htPage| |value|) + (PROG (|parts| |ISTMP#1| |ISTMP#2| |predicate| |restParts| + |continue|) + (RETURN + (PROGN + (SPADLET |parts| (|htpProperty| |htPage| '|parts|)) + (SPADLET |continue| + (COND + ((NULL |parts|) NIL) + ((AND (PAIRP |parts|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |parts|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|break|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |predicate| + (QCAR |ISTMP#2|)) + 'T))))) + (PROGN + (SPADLET |restParts| (QCDR |parts|)) + 'T)) + (|eval| |predicate|)) + ('T 'T))) + (COND + (|continue| (|htpSetProperty| |htPage| '|parts| |restParts|) + (|htShowFunctionPageContinued| |htPage|)) + ('T (|htKill| |htPage| |value|))))))) + +;htKill(htPage,value) == +; htInitPage('"System Command", nil) +; string := STRCONC('"{\em )set ",listOfStrings2String [value,:$path],'"}") +; htMakePage [ +; '(text +; "{Here is the AXIOM system command you could have issued:}" +; "\vspace{2}\newline\centerline{\tt"), +; ['text,:string]] +; htMakePage '((text . "}\vspace{1}\newline\rm")) +; htSay '"\vspace{2}{Select \ \UpButton{} \ to go back.}" +; htSay '"\newline{Select \ \ExitButton{QuitPage} \ to remove this window.}" +; htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] +; htShowPage() + +(DEFUN |htKill| (|htPage| |value|) + (declare (ignore |htPage|)) + (PROG (|string|) + (declare (special |$path|)) + (RETURN + (PROGN + (|htInitPage| (MAKESTRING "System Command") NIL) + (SPADLET |string| + (STRCONC (MAKESTRING "{\\em )set ") + (|listOfStrings2String| + (CONS |value| |$path|)) + (MAKESTRING "}"))) + (|htMakePage| + (CONS '(|text| "{Here is the AXIOM system command you could have issued:}" + "\\vspace{2}\\newline\\centerline{\\tt") + (CONS (CONS '|text| |string|) NIL))) + (|htMakePage| '((|text| . "}\\vspace{1}\\newline\\rm"))) + (|htSay| (MAKESTRING + "\\vspace{2}{Select \\ \\UpButton{} \\ to go back.}")) + (|htSay| (MAKESTRING + "\\newline{Select \\ \\ExitButton{QuitPage} \\ to remove this window.}")) + (|htProcessDoitButton| + (CONS (MAKESTRING "Press to Remove Page") + (CONS (MAKESTRING "") (CONS '|htDoNothing| NIL)))) + (|htShowPage|))))) + +;htSetNotAvailable(htPage,whatToType) == +; page := htInitPage('"Unavailable Set Command", htpPropertyList htPage) +; htInitPage('"Unavailable System Command", nil) +; string := STRCONC('"{\em ",whatToType,'"}") +; htMakePage [ +; '(text "\vspace{1}\newline" +; "{Sorry, but this system command is not available through HyperDoc. Please directly issue this command in an AXIOM window for more information:}" +; "\vspace{2}\newline\centerline{\tt"), +; ['text,:string]] +; htMakePage '((text . "}\vspace{1}\newline")) +; htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] +; htShowPage() + +(DEFUN |htSetNotAvailable| (|htPage| |whatToType|) + (PROG (|page| |string|) + (RETURN + (PROGN + (SPADLET |page| + (|htInitPage| (MAKESTRING "Unavailable Set Command") + (|htpPropertyList| |htPage|))) + (|htInitPage| (MAKESTRING "Unavailable System Command") NIL) + (SPADLET |string| + (STRCONC (MAKESTRING "{\\em ") |whatToType| + (MAKESTRING "}"))) + (|htMakePage| + (CONS '(|text| "\\vspace{1}\\newline" + "{Sorry, but this system command is not available through HyperDoc. Please directly issue this command in an AXIOM window for more information:}" + "\\vspace{2}\\newline\\centerline{\\tt") + (CONS (CONS '|text| |string|) NIL))) + (|htMakePage| '((|text| . "}\\vspace{1}\\newline"))) + (|htProcessDoitButton| + (CONS (MAKESTRING "Press to Remove Page") + (CONS (MAKESTRING "") (CONS '|htDoNothing| NIL)))) + (|htShowPage|))))) + +;htDoNothing(htPage,command) == nil + +(DEFUN |htDoNothing| (|htPage| |command|) + (declare (ignore |htPage| |command|)) + NIL) + +;htCheck(checker,value) == +; PAIRP checker => htCheckList(checker,parseWord value) +; FUNCALL(checker,value) + +(DEFUN |htCheck| (|checker| |value|) + (COND + ((PAIRP |checker|) (|htCheckList| |checker| (|parseWord| |value|))) + ('T (FUNCALL |checker| |value|)))) + +;parseWord x == +; STRINGP x => +; and/[DIGITP x.i for i in 0..MAXINDEX x] => PARSE_-INTEGER x +; INTERN x +; x + +(DEFUN |parseWord| (|x|) + (PROG () + (RETURN + (SEQ (COND + ((STRINGP |x|) + (COND + ((PROG (G167588) + (SPADLET G167588 'T) + (RETURN + (DO ((G167594 NIL (NULL G167588)) + (G167595 (MAXINDEX |x|)) + (|i| 0 (QSADD1 |i|))) + ((OR G167594 (QSGREATERP |i| G167595)) + G167588) + (SEQ (EXIT (SETQ G167588 + (AND G167588 + (DIGITP (ELT |x| |i|))))))))) + (PARSE-INTEGER |x|)) + ('T (INTERN |x|)))) + ('T |x|)))))) + +;htCheckList(checker,value) == +; if value in '(y ye yes Y YE YES) then value := 'yes +; if value in '(n no N NO) then value := 'no +; checker is [n,m] and INTEGERP n => +; m = n + 1 => +; value in checker => value +; n +; null m => +; INTEGERP value and value >= n => value +; n +; INTEGERP m => +; INTEGERP value and value >= n and value <= m => value +; n +; value in checker => value +; first checker + +(DEFUN |htCheckList| (|checker| |value|) + (PROG (|n| |ISTMP#1| |m|) + (RETURN + (PROGN + (COND + ((|member| |value| '(|y| |ye| |yes| Y YE YES)) + (SPADLET |value| '|yes|))) + (COND + ((|member| |value| '(|n| |no| N NO)) (SPADLET |value| '|no|))) + (COND + ((AND (PAIRP |checker|) + (PROGN + (SPADLET |n| (QCAR |checker|)) + (SPADLET |ISTMP#1| (QCDR |checker|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |m| (QCAR |ISTMP#1|)) 'T))) + (INTEGERP |n|)) + (COND + ((BOOT-EQUAL |m| (PLUS |n| 1)) + (COND ((|member| |value| |checker|) |value|) ('T |n|))) + ((NULL |m|) + (COND + ((AND (INTEGERP |value|) (>= |value| |n|)) |value|) + ('T |n|))) + ((INTEGERP |m|) + (COND + ((AND (INTEGERP |value|) (>= |value| |n|) + (<= |value| |m|)) + |value|) + ('T |n|))))) + ((|member| |value| |checker|) |value|) + ('T (CAR |checker|))))))) + +;-- emlist := "STRCONC"/[STRCONC('" {\em ",PNAME x,'"} ") for x in checker] +;-- STRCONC('"Please enter one of: ",emlist) +;translateYesNoToTrueFalse x == +; x = 'yes => true +; x = 'no => false +; x + +(DEFUN |translateYesNoToTrueFalse| (|x|) + (COND + ((BOOT-EQUAL |x| '|yes|) 'T) + ((BOOT-EQUAL |x| '|no|) NIL) + ('T |x|))) + +;chkNameList x == +; u := bcString2ListWords x +; parsedNames := [ncParseFromString x for x in u] +; and/[IDENTP x for x in parsedNames] => parsedNames +; '"Please enter a list of identifiers separated by blanks" + +(DEFUN |chkNameList| (|x|) + (PROG (|u| |parsedNames|) + (RETURN + (SEQ (PROGN + (SPADLET |u| (|bcString2ListWords| |x|)) + (SPADLET |parsedNames| + (PROG (G167635) + (SPADLET G167635 NIL) + (RETURN + (DO ((G167640 |u| (CDR G167640)) + (|x| NIL)) + ((OR (ATOM G167640) + (PROGN + (SETQ |x| (CAR G167640)) + NIL)) + (NREVERSE0 G167635)) + (SEQ (EXIT (SETQ G167635 + (CONS (|ncParseFromString| |x|) + G167635)))))))) + (COND + ((PROG (G167646) + (SPADLET G167646 'T) + (RETURN + (DO ((G167652 NIL (NULL G167646)) + (G167653 |parsedNames| (CDR G167653)) + (|x| NIL)) + ((OR G167652 (ATOM G167653) + (PROGN (SETQ |x| (CAR G167653)) NIL)) + G167646) + (SEQ (EXIT (SETQ G167646 + (AND G167646 (IDENTP |x|)))))))) + |parsedNames|) + ('T + (MAKESTRING + "Please enter a list of identifiers separated by blanks")))))))) + +;chkPosInteger s == +; (u := parseOnly s) and INTEGERP u and u > 0 => u +; '"Please enter a positive integer" + +(DEFUN |chkPosInteger| (|s|) + (PROG (|u|) + (RETURN + (COND + ((AND (SPADLET |u| (|parseOnly| |s|)) (INTEGERP |u|) (> |u| 0)) + |u|) + ('T (MAKESTRING "Please enter a positive integer")))))) + +;chkOutputFileName s == +; bcString2WordList s in '(CONSOLE console) => 'console +; chkDirectory s + +(DEFUN |chkOutputFileName| (|s|) + (COND + ((|member| (|bcString2WordList| |s|) '(CONSOLE |console|)) + '|console|) + ('T (|chkDirectory| |s|)))) + +;chkDirectory s == s + +(DEFUN |chkDirectory| (|s|) |s|) + +;chkNonNegativeInteger s == +; (u := ncParseFromString s) and INTEGERP u and u >= 0 => u +; '"Please enter a non-negative integer" + +(DEFUN |chkNonNegativeInteger| (|s|) + (PROG (|u|) + (RETURN + (COND + ((AND (SPADLET |u| (|ncParseFromString| |s|)) (INTEGERP |u|) + (>= |u| 0)) + |u|) + ('T (MAKESTRING "Please enter a non-negative integer")))))) + +;chkRange s == +; (u := ncParseFromString s) and INTEGERP u +; and u >= $htInitial and (NULL $htFinal or u <= $htFinal) +; => u +; null $htFinal => +; STRCONC('"Please enter an integer greater than ",stringize ($htInitial - 1)) +; STRCONC('"Please enter an integer between ",stringize $htInitial,'" and ", +; stringize $htFinal) + +(DEFUN |chkRange| (|s|) + (PROG (|u|) + (declare (special |$htFinal| |$htInitial|)) + (RETURN + (COND + ((AND (SPADLET |u| (|ncParseFromString| |s|)) (INTEGERP |u|) + (>= |u| |$htInitial|) + (OR (NULL |$htFinal|) (<= |u| |$htFinal|))) + |u|) + ((NULL |$htFinal|) + (STRCONC (MAKESTRING "Please enter an integer greater than ") + (|stringize| (SPADDIFFERENCE |$htInitial| 1)))) + ('T + (STRCONC (MAKESTRING "Please enter an integer between ") + (|stringize| |$htInitial|) (MAKESTRING " and ") + (|stringize| |$htFinal|))))))) + +;chkAllNonNegativeInteger s == +; (u := ncParseFromString s) and u in '(a al all A AL ALL) and 'ALL +; or chkNonNegativeInteger s +; or '"Please enter {\em all} or a non-negative integer" + +(DEFUN |chkAllNonNegativeInteger| (|s|) + (PROG (|u|) + (RETURN + (OR (AND (SPADLET |u| (|ncParseFromString| |s|)) + (|member| |u| '(|a| |al| |all| A AL ALL)) 'ALL) + (|chkNonNegativeInteger| |s|) + (MAKESTRING + "Please enter {\\em all} or a non-negative integer"))))) + +;htMakePathKey path == +; null path => systemError '"path is not set" +; INTERN fn(PNAME first path,rest path) where +; fn(a,b) == +; null b => a +; fn(STRCONC(a,'".",PNAME first b),rest b) + +(DEFUN |htMakePathKey,fn| (|a| |b|) + (SEQ (IF (NULL |b|) (EXIT |a|)) + (EXIT (|htMakePathKey,fn| + (STRCONC |a| (MAKESTRING ".") (PNAME (CAR |b|))) + (CDR |b|))))) + +(DEFUN |htMakePathKey| (|path|) + (COND + ((NULL |path|) (|systemError| (MAKESTRING "path is not set"))) + ('T + (INTERN (|htMakePathKey,fn| (PNAME (CAR |path|)) (CDR |path|)))))) + +;htMarkTree(tree,n) == +; RPLACD(LASTTAIL tree,n) +; for branch in tree repeat +; branch.3 = 'TREE => htMarkTree(branch.5,n + 1) + +(DEFUN |htMarkTree| (|tree| |n|) + (SEQ (PROGN + (RPLACD (LASTTAIL |tree|) |n|) + (SEQ (DO ((G167706 |tree| (CDR G167706)) (|branch| NIL)) + ((OR (ATOM G167706) + (PROGN (SETQ |branch| (CAR G167706)) NIL)) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL (ELT |branch| 3) 'TREE) + (EXIT (|htMarkTree| (ELT |branch| 5) + (PLUS |n| 1)))))))))))) + +;htSetHistory htPage == +; msg := "when the history facility is on (yes), results of computations are saved in memory" +; data := ['history,msg,'history,'LITERALS,'$HiFiAccess,'(on off yes no)] +; htShowLiteralsPage(htPage,data) + +(DEFUN |htSetHistory| (|htPage|) + (PROG (|msg| |data|) + (RETURN + (PROGN + (SPADLET |msg| + '|when the history facility is on (yes), results of computations are saved in memory|) + (SPADLET |data| + (CONS '|history| + (CONS |msg| + (CONS '|history| + (CONS 'LITERALS + (CONS '|$HiFiAccess| + (CONS '(|on| |off| |yes| |no|) + NIL))))))) + (|htShowLiteralsPage| |htPage| |data|))))) + +;htSetOutputLibrary htPage == +; htSetNotAvailable(htPage,'")set compiler output") + +(DEFUN |htSetOutputLibrary| (|htPage|) + (|htSetNotAvailable| |htPage| (MAKESTRING ")set compiler output"))) + +;htSetInputLibrary htPage == +; htSetNotAvailable(htPage,'")set compiler input") + +(DEFUN |htSetInputLibrary| (|htPage|) + (|htSetNotAvailable| |htPage| (MAKESTRING ")set compiler input"))) + +;htSetExpose htPage == +; htSetNotAvailable(htPage,'")set expose") + +(DEFUN |htSetExpose| (|htPage|) + (|htSetNotAvailable| |htPage| (MAKESTRING ")set expose"))) + +;htSetKernelProtect htPage == +; htSetNotAvailable(htPage,'")set kernel protect") + +(DEFUN |htSetKernelProtect| (|htPage|) + (|htSetNotAvailable| |htPage| (MAKESTRING ")set kernel protect"))) + +;htSetKernelWarn htPage == +; htSetNotAvailable(htPage,'")set kernel warn") + +(DEFUN |htSetKernelWarn| (|htPage|) + (|htSetNotAvailable| |htPage| (MAKESTRING ")set kernel warn"))) + +;htSetOutputCharacters htPage == +; htSetNotAvailable(htPage,'")set output characters") + +(DEFUN |htSetOutputCharacters| (|htPage|) + (|htSetNotAvailable| |htPage| (MAKESTRING ")set output characters"))) + +;htSetLinkerArgs htPage == +; htSetNotAvailable(htPage,'")set fortran calling linker") + +(DEFUN |htSetLinkerArgs| (|htPage|) + (|htSetNotAvailable| |htPage| + (MAKESTRING ")set fortran calling linker"))) + +;htSetCache(htPage,:options) == +; $path := '(functions cache) +; htPage := htInitPage(mkSetTitle(),nil) +; $valueList := nil +; htMakePage '( +; (text +; "Use this system command to cause the AXIOM interpreter to `remember' " +; "past values of interpreter functions. " +; "To remember a past value of a function, the interpreter " +; "sets up a {\em cache} for that function based on argument values. " +; "When a value is cached for a given argument value, its value is gotten " +; "from the cache and not recomputed. Caching can often save much " +; "computing time, particularly with recursive functions or functions that " +; "are expensive to compute and that are called repeatedly " +; "with the same argument." +; "\vspace{1}\newline ") +; (domainConditions (Satisfies S chkNameList)) +; (text +;"Enter below a list of interpreter functions you would like specially cached." +; "Use the name {\em all} to give a default setting for all " +; "interpreter functions. " +; "\vspace{1}\newline " +; "Enter {\em all} or a list of names (separate names by blanks):") +; (inputStrings ("" "" 60 "all" names S)) +; (doneButton "Push to enter names" htCacheAddChoice)) +; htShowPage() + +(DEFUN |htSetCache| (&REST G167749 &AUX |options| |htPage|) + (declare (special |$valueList| |$path|)) + (DSETQ (|htPage| . |options|) G167749) + (PROGN + (SPADLET |$path| '(|functions| |cache|)) + (SPADLET |htPage| (|htInitPage| (|mkSetTitle|) NIL)) + (SPADLET |$valueList| NIL) + (|htMakePage| + '((|text| + "Use this system command to cause the AXIOM interpreter to `remember' " + "past values of interpreter functions. " + "To remember a past value of a function, the interpreter " + "sets up a {\\em cache} for that function based on argument values. " + "When a value is cached for a given argument value, its value is gotten " + "from the cache and not recomputed. Caching can often save much " + "computing time, particularly with recursive functions or functions that " + "are expensive to compute and that are called repeatedly " + "with the same argument." "\\vspace{1}\\newline ") + (|domainConditions| (|Satisfies| S |chkNameList|)) + (|text| +"Enter below a list of interpreter functions you would like specially cached. " + "Use the name {\\em all} to give a default setting for all " + "interpreter functions. " "\\vspace{1}\\newline " + "Enter {\\em all} or a list of names (separate names by blanks):") + (|inputStrings| ("" "" 60 "all" |names| S)) + (|doneButton| "Push to enter names" |htCacheAddChoice|))) + (|htShowPage|))) + +;htCacheAddChoice htPage == +; names := bcString2WordList htpLabelInputString(htPage,'names) +; $valueList := [listOfStrings2String names,:$valueList] +; null names => htCacheAddQuery() +; null rest names => htCacheOne names +; page := htInitPage(mkSetTitle(),nil) +; htpSetProperty(page,'names,names) +; htMakePage '( +; (domainConditions (Satisfies ALLPI chkAllPositiveInteger)) +; (text +; "For each function, enter below a {\em cache length}, a positive integer. " +; "This number tells how many past values will " +; "be cached. " +; "A cache length of {\em 0} means the function won't be cached. " +; "To cache all past values, " +; "enter {\em all}." +; "\vspace{1}\newline " +; "For each function name, enter {\em all} or a positive integer:")) +; for i in 1.. for name in names repeat htMakePage [ +; ['inputStrings, +; [STRCONC('"Function {\em ",name,'"} will cache"), +; '"values",5,10,htMakeLabel('"c",i),'ALLPI]]] +; htSetvarDoneButton('"Select to Set Values",'htCacheSet) +; htShowPage() + +(DEFUN |htCacheAddChoice| (|htPage|) + (PROG (|names| |page|) + (declare (special |$valueList|)) + (RETURN + (SEQ (PROGN + (SPADLET |names| + (|bcString2WordList| + (|htpLabelInputString| |htPage| '|names|))) + (SPADLET |$valueList| + (CONS (|listOfStrings2String| |names|) + |$valueList|)) + (COND + ((NULL |names|) (|htCacheAddQuery|)) + ((NULL (CDR |names|)) (|htCacheOne| |names|)) + ('T (SPADLET |page| (|htInitPage| (|mkSetTitle|) NIL)) + (|htpSetProperty| |page| '|names| |names|) + (|htMakePage| + '((|domainConditions| + (|Satisfies| ALLPI |chkAllPositiveInteger|)) + (|text| "For each function, enter below a {\\em cache length}, a positive integer. " + "This number tells how many past values will " + "be cached. " + "A cache length of {\\em 0} means the function won't be cached. " + "To cache all past values, " + "enter {\\em all}." + "\\vspace{1}\\newline " + "For each function name, enter {\\em all} or a positive integer:"))) + (DO ((|i| 1 (QSADD1 |i|)) + (G167755 |names| (CDR G167755)) (|name| NIL)) + ((OR (ATOM G167755) + (PROGN (SETQ |name| (CAR G167755)) NIL)) + NIL) + (SEQ (EXIT (|htMakePage| + (CONS (CONS '|inputStrings| + (CONS + (CONS + (STRCONC + (MAKESTRING + "Function {\\em ") + |name| + (MAKESTRING "} will cache")) + (CONS (MAKESTRING "values") + (CONS 5 + (CONS 10 + (CONS + (|htMakeLabel| + (MAKESTRING "c") |i|) + (CONS 'ALLPI NIL)))))) + NIL)) + NIL))))) + (|htSetvarDoneButton| + (MAKESTRING "Select to Set Values") '|htCacheSet|) + (|htShowPage|)))))))) + +;htMakeLabel(prefix,i) == INTERN STRCONC(prefix,stringize i) + +(DEFUN |htMakeLabel| (|prefix| |i|) + (INTERN (STRCONC |prefix| (|stringize| |i|)))) + +;htCacheSet htPage == +; names := htpProperty(htPage,'names) +; for i in 1.. for name in names repeat +; num := chkAllNonNegativeInteger +; htpLabelInputString(htPage,htMakeLabel('"c",i)) +; $cacheAlist := ADDASSOC(INTERN name,num,$cacheAlist) +; if (n := LASSOC('all,$cacheAlist)) then +; $cacheCount := n +; $cacheAlist := deleteAssoc('all,$cacheAlist) +; htInitPage('"Cache Summary",nil) +; bcHt '"In general, interpreter functions " +; bcHt +; $cacheCount = 0 => "will {\em not} be cached." +; bcHt '"cache " +; htAllOrNum $cacheCount +; '"} values." +; bcHt '"\vspace{1}\newline " +; if $cacheAlist then +;-- bcHt '" However, \indent{3}" +; for [name,:val] in $cacheAlist | val ^= $cacheCount repeat +; bcHt '"\newline function {\em " +; bcHt stringize name +; bcHt '"} will cache " +; htAllOrNum val +; bcHt '"} values" +; htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] +; htShowPage() + +(DEFUN |htCacheSet| (|htPage|) + (PROG (|names| |num| |n| |name| |val|) + (declare (special |$cacheCount| |$cacheAlist|)) + (RETURN + (SEQ (PROGN + (SPADLET |names| (|htpProperty| |htPage| '|names|)) + (DO ((|i| 1 (QSADD1 |i|)) + (G167785 |names| (CDR G167785)) (|name| NIL)) + ((OR (ATOM G167785) + (PROGN (SETQ |name| (CAR G167785)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |num| + (|chkAllNonNegativeInteger| + (|htpLabelInputString| |htPage| + (|htMakeLabel| (MAKESTRING "c") + |i|)))) + (SPADLET |$cacheAlist| + (ADDASSOC (INTERN |name|) |num| + |$cacheAlist|)))))) + (COND + ((SPADLET |n| (LASSOC '|all| |$cacheAlist|)) + (SPADLET |$cacheCount| |n|) + (SPADLET |$cacheAlist| + (|deleteAssoc| '|all| |$cacheAlist|)))) + (|htInitPage| (MAKESTRING "Cache Summary") NIL) + (|bcHt| (MAKESTRING "In general, interpreter functions ")) + (|bcHt| (COND + ((EQL |$cacheCount| 0) + '|will {\\em not} be cached.|) + ('T (|bcHt| (MAKESTRING "cache ")) + (|htAllOrNum| |$cacheCount|) + (MAKESTRING "} values.")))) + (|bcHt| (MAKESTRING "\\vspace{1}\\newline ")) + (COND + (|$cacheAlist| + (DO ((G167801 |$cacheAlist| (CDR G167801)) + (G167774 NIL)) + ((OR (ATOM G167801) + (PROGN + (SETQ G167774 (CAR G167801)) + NIL) + (PROGN + (PROGN + (SPADLET |name| (CAR G167774)) + (SPADLET |val| (CDR G167774)) + G167774) + NIL)) + NIL) + (SEQ (EXIT (COND + ((NEQUAL |val| |$cacheCount|) + (PROGN + (|bcHt| + (MAKESTRING + "\\newline function {\\em ")) + (|bcHt| (|stringize| |name|)) + (|bcHt| + (MAKESTRING "} will cache ")) + (|htAllOrNum| |val|) + (|bcHt| (MAKESTRING "} values")))))))))) + (|htProcessDoitButton| + (CONS (MAKESTRING "Press to Remove Page") + (CONS (MAKESTRING "") (CONS '|htDoNothing| NIL)))) + (|htShowPage|)))))) + +;htAllOrNum val == bcHt +; val = 'all => '"{\em all" +; val = 0 => '"{\em no" +; STRCONC('"the last {\em ",stringize val) + +(DEFUN |htAllOrNum| (|val|) + (|bcHt| (COND + ((BOOT-EQUAL |val| '|all|) (MAKESTRING "{\\em all")) + ((EQL |val| 0) (MAKESTRING "{\\em no")) + ('T + (STRCONC (MAKESTRING "the last {\\em ") + (|stringize| |val|)))))) + +;htCacheOne names == +; page := htInitPage(mkSetTitle(),nil) +; htpSetProperty(page,'names,names) +; htMakePage '( +; (domainConditions (Satisfies ALLPI chkAllPositiveInteger)) +; (text +; "Enter below a {\em cache length}, a positive integer. " +; "This number tells how many past values will " +; "be cached. To cache all past values, " +; "enter {\em all}." +; "\vspace{1}\newline ") +; (inputStrings +; ("Enter {\em all} or a positive integer:" +; "" 5 10 c1 ALLPI))) +; htSetvarDoneButton('"Select to Set Value",'htCacheSet) +; htShowPage() + +(DEFUN |htCacheOne| (|names|) + (PROG (|page|) + (RETURN + (PROGN + (SPADLET |page| (|htInitPage| (|mkSetTitle|) NIL)) + (|htpSetProperty| |page| '|names| |names|) + (|htMakePage| + '((|domainConditions| + (|Satisfies| ALLPI |chkAllPositiveInteger|)) + (|text| "Enter below a {\\em cache length}, a positive integer. " + "This number tells how many past values will " + "be cached. To cache all past values, " + "enter {\\em all}." "\\vspace{1}\\newline ") + (|inputStrings| + ("Enter {\\em all} or a positive integer:" "" 5 10 + |c1| ALLPI)))) + (|htSetvarDoneButton| (MAKESTRING "Select to Set Value") + '|htCacheSet|) + (|htShowPage|))))) + +;$historyDisplayWidth := 120 + +(SPADLET |$historyDisplayWidth| 120) + +;$newline := char 10 + +(SPADLET |$newline| (|char| 10)) + +;downlink page == +; $saturn => downlinkSaturn page +; htInitPage('"Bridge",nil) +; htSay('"\replacepage{", page, '"}") +; htShowPage() + +(DEFUN |downlink| (|page|) + (declare (special |$saturn|)) + (COND + (|$saturn| (|downlinkSaturn| |page|)) + ('T (|htInitPage| (MAKESTRING "Bridge") NIL) + (|htSay| (MAKESTRING "\\replacepage{") |page| (MAKESTRING "}")) + (|htShowPage|)))) + +;downlinkSaturn fn == +; u := dbReadLines(fn) +; lines := '"" +; while u is [line,:u] repeat +; n := MAXINDEX line +; n < 1 => nil +; line.0 = (char '_%) => nil +; lines := STRCONC(lines,line) +; issueHTSaturn lines + +(DEFUN |downlinkSaturn| (|fn|) + (PROG (|line| |u| |n| |lines|) + (RETURN + (SEQ (PROGN + (SPADLET |u| (|dbReadLines| |fn|)) + (SPADLET |lines| (MAKESTRING "")) + (DO () + ((NULL (AND (PAIRP |u|) + (PROGN + (SPADLET |line| (QCAR |u|)) + (SPADLET |u| (QCDR |u|)) + 'T))) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |n| (MAXINDEX |line|)) + (COND + ((> 1 |n|) NIL) + ((BOOT-EQUAL (ELT |line| 0) (|char| '%)) + NIL) + ('T + (SPADLET |lines| + (STRCONC |lines| |line|)))))))) + (|issueHTSaturn| |lines|)))))) + +;dbNonEmptyPattern pattern == +; null pattern => '"*" +; pattern := STRINGIMAGE pattern +; #pattern > 0 => pattern +; '"*" + +(DEFUN |dbNonEmptyPattern| (|pattern|) + (COND + ((NULL |pattern|) (MAKESTRING "*")) + ('T (SPADLET |pattern| (STRINGIMAGE |pattern|)) + (COND ((> (|#| |pattern|) 0) |pattern|) ('T (MAKESTRING "*")))))) + +;htSystemVariables() == main where +; main == +; not $fullScreenSysVars => htSetVars() +; classlevel := $UserLevel +; $levels : local := '(compiler development interpreter) +; $heading : local := nil +; while classlevel ^= first $levels repeat $levels := rest $levels +; table := NREVERSE fn($setOptions,nil,true) +; htInitPage('"System Variables",nil) +; htSay '"\beginmenu" +; lastHeading := nil +; for [heading,name,message,.,key,variable,options,func] in table repeat +; htSay('"\newline\item ") +; if heading = lastHeading then htSay '"\tab{8}" else +; htSay(heading,'"\tab{8}") +; lastHeading := heading +; htSay('"{\em ",name,"}\tab{22}",message) +; htSay('"\tab{80}") +; key = 'FUNCTION => +; null options => htMakePage [['bcLinks,['"reset",'"",func,nil]]] +; [msg,class,var,valuesOrFunction,:.] := first options --skip first message +; functionTail(name,class,var,valuesOrFunction) +; for option in rest options repeat +; option is ['break,:.] => 'skip +; [msg,class,var,valuesOrFunction,:.] := option +; htSay('"\newline\tab{22}", msg,'"\tab{80}") +; functionTail(name,class,var,valuesOrFunction) +; val := eval variable +; displayOptions(name,key,variable,val,options) +; htSay '"\endmenu" +; htShowPage() +; functionTail(name,class,var,valuesOrFunction) == +; val := eval var +; atom valuesOrFunction => +; htMakePage '((domainConditions (isDomain STR (String)))) +;htMakePage [['bcLinks,['"reset",'"",'htSetSystemVariableKind,[var,name,nil]]]] +; htMakePage [['bcStrings,[30,STRINGIMAGE val,name,valuesOrFunction]]] +; displayOptions(name,class,var,val,valuesOrFunction) +; displayOptions(name,class,variable,val,options) == +; class = 'INTEGER => +; htMakePage [['bcLispLinks,[[['text,options.0,'"-",options.1 or '""]],'"",'htSetSystemVariableKind,[variable,name,'PARSE_-INTEGER]]]] +; htMakePage '((domainConditions (isDomain INT (Integer)))) +; htMakePage [['bcStrings,[5,STRINGIMAGE val,name,'INT]]] +; class = 'STRING => +; htSay('"{\em ",val,'"}\space{1}") +; for x in options repeat +; val = x or val = true and x = 'on or null val and x = 'off => +; htSay('"{\em ",x,'"}\space{1}") +; htMakePage [['bcLispLinks,[x,'" ",'htSetSystemVariable,[variable,x]]]] +; fn(t,al,firstTime) == +; atom t => al +; if firstTime then $heading := opOf first t +; fn(rest t,gn(first t,al),firstTime) +; gn(t,al) == +; [.,.,class,key,.,options,:.] := t +; not MEMQ(class,$levels) => al +; key = 'LITERALS or key = 'INTEGER or key = 'STRING => [[$heading,:t],:al] +; key = 'TREE => fn(options,al,false) +; key = 'FUNCTION => [[$heading,:t],:al] +; systemError key + +(DEFUN |htSystemVariables,gn| (|t| |al|) + (PROG (|class| |key| |options|) + (declare (special |$heading| |$levels|)) + (RETURN + (SEQ (PROGN + (SPADLET |class| (CADDR |t|)) + (SPADLET |key| (CADDDR |t|)) + (SPADLET |options| (CADR (CDDDDR |t|))) + |t|) + (IF (NULL (MEMQ |class| |$levels|)) (EXIT |al|)) + (IF (OR (OR (BOOT-EQUAL |key| 'LITERALS) + (BOOT-EQUAL |key| 'INTEGER)) + (BOOT-EQUAL |key| 'STRING)) + (EXIT (CONS (CONS |$heading| |t|) |al|))) + (IF (BOOT-EQUAL |key| 'TREE) + (EXIT (|htSystemVariables,fn| |options| |al| NIL))) + (IF (BOOT-EQUAL |key| 'FUNCTION) + (EXIT (CONS (CONS |$heading| |t|) |al|))) + (EXIT (|systemError| |key|)))))) + +(DEFUN |htSystemVariables,fn| (|t| |al| |firstTime|) + (declare (special |$heading|)) + (SEQ (IF (ATOM |t|) (EXIT |al|)) + (IF |firstTime| (SPADLET |$heading| (|opOf| (CAR |t|))) NIL) + (EXIT (|htSystemVariables,fn| (CDR |t|) + (|htSystemVariables,gn| (CAR |t|) |al|) |firstTime|)))) + +(DEFUN |htSystemVariables,displayOptions| + (|name| |class| |variable| |val| |options|) + (SEQ (IF (BOOT-EQUAL |class| 'INTEGER) + (EXIT (SEQ (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS + (CONS + (CONS + (CONS '|text| + (CONS (ELT |options| 0) + (CONS (MAKESTRING "-") + (CONS + (OR (ELT |options| 1) + (MAKESTRING "")) + NIL)))) + NIL) + (CONS (MAKESTRING "") + (CONS + '|htSetSystemVariableKind| + (CONS + (CONS |variable| + (CONS |name| + (CONS 'PARSE-INTEGER NIL))) + NIL)))) + NIL)) + NIL)) + (|htMakePage| + '((|domainConditions| + (|isDomain| INT (|Integer|))))) + (EXIT (|htMakePage| + (CONS (CONS '|bcStrings| + (CONS + (CONS 5 + (CONS (STRINGIMAGE |val|) + (CONS |name| (CONS 'INT NIL)))) + NIL)) + NIL)))))) + (IF (BOOT-EQUAL |class| 'STRING) + (EXIT (|htSay| (MAKESTRING "{\\em ") |val| + (MAKESTRING "}\\space{1}")))) + (EXIT (DO ((G167913 |options| (CDR G167913)) (|x| NIL)) + ((OR (ATOM G167913) + (PROGN (SETQ |x| (CAR G167913)) NIL)) + NIL) + (SEQ (IF (OR (OR (BOOT-EQUAL |val| |x|) + (AND (BOOT-EQUAL |val| 'T) + (BOOT-EQUAL |x| '|on|))) + (AND (NULL |val|) (BOOT-EQUAL |x| '|off|))) + (EXIT (|htSay| (MAKESTRING "{\\em ") |x| + (MAKESTRING "}\\space{1}")))) + (EXIT (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS + (CONS |x| + (CONS (MAKESTRING " ") + (CONS '|htSetSystemVariable| + (CONS + (CONS |variable| + (CONS |x| NIL)) + NIL)))) + NIL)) + NIL)))))))) + +(DEFUN |htSystemVariables,functionTail| + (|name| |class| |var| |valuesOrFunction|) + (PROG (|val|) + (RETURN + (SEQ (SPADLET |val| (|eval| |var|)) + (IF (ATOM |valuesOrFunction|) + (EXIT (SEQ (|htMakePage| + '((|domainConditions| + (|isDomain| STR (|String|))))) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS + (CONS (MAKESTRING "reset") + (CONS (MAKESTRING "") + (CONS + '|htSetSystemVariableKind| + (CONS + (CONS |var| + (CONS |name| (CONS NIL NIL))) + NIL)))) + NIL)) + NIL)) + (EXIT (|htMakePage| + (CONS + (CONS '|bcStrings| + (CONS + (CONS 30 + (CONS (STRINGIMAGE |val|) + (CONS |name| + (CONS |valuesOrFunction| NIL)))) + NIL)) + NIL)))))) + (EXIT (|htSystemVariables,displayOptions| |name| |class| + |var| |val| |valuesOrFunction|)))))) + +(DEFUN |htSystemVariables| () + (PROG (|$levels| |$heading| |classlevel| |table| |heading| |name| + |message| |key| |variable| |options| |func| |lastHeading| + |LETTMP#1| |msg| |class| |var| |valuesOrFunction| |val|) + (DECLARE (SPECIAL |$levels| |$heading| |$setOptions| |$UserLevel| + |$fullScreenSysVars|)) + (RETURN + (SEQ (COND + ((NULL |$fullScreenSysVars|) (|htSetVars|)) + ('T (SPADLET |classlevel| |$UserLevel|) + (SPADLET |$levels| '(|compiler| |development| |interpreter|)) + (SPADLET |$heading| NIL) + (DO () ((NULL (NEQUAL |classlevel| (CAR |$levels|))) NIL) + (SEQ (EXIT (SPADLET |$levels| (CDR |$levels|))))) + (SPADLET |table| + (NREVERSE + (|htSystemVariables,fn| |$setOptions| NIL + 'T))) + (|htInitPage| (MAKESTRING "System Variables") NIL) + (|htSay| (MAKESTRING "\\beginmenu")) + (SPADLET |lastHeading| NIL) + (DO ((G167961 |table| (CDR G167961)) (G167879 NIL)) + ((OR (ATOM G167961) + (PROGN (SETQ G167879 (CAR G167961)) NIL) + (PROGN + (PROGN + (SPADLET |heading| (CAR G167879)) + (SPADLET |name| (CADR G167879)) + (SPADLET |message| (CADDR G167879)) + (SPADLET |key| (CAR (CDDDDR G167879))) + (SPADLET |variable| + (CADR (CDDDDR G167879))) + (SPADLET |options| + (CADDR (CDDDDR G167879))) + (SPADLET |func| (CADDDR (CDDDDR G167879))) + G167879) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|htSay| (MAKESTRING "\\newline\\item ")) + (COND + ((BOOT-EQUAL |heading| |lastHeading|) + (|htSay| (MAKESTRING "\\tab{8}"))) + ('T + (|htSay| |heading| + (MAKESTRING "\\tab{8}")) + (SPADLET |lastHeading| |heading|))) + (|htSay| (MAKESTRING "{\\em ") |name| + '|}\\tab{22}| |message|) + (|htSay| (MAKESTRING "\\tab{80}")) + (COND + ((BOOT-EQUAL |key| 'FUNCTION) + (COND + ((NULL |options|) + (|htMakePage| + (CONS + (CONS '|bcLinks| + (CONS + (CONS (MAKESTRING "reset") + (CONS (MAKESTRING "") + (CONS |func| (CONS NIL NIL)))) + NIL)) + NIL))) + ('T + (SPADLET |LETTMP#1| (CAR |options|)) + (SPADLET |msg| (CAR |LETTMP#1|)) + (SPADLET |class| (CADR |LETTMP#1|)) + (SPADLET |var| (CADDR |LETTMP#1|)) + (SPADLET |valuesOrFunction| + (CADDDR |LETTMP#1|)) + (|htSystemVariables,functionTail| + |name| |class| |var| + |valuesOrFunction|) + (DO + ((G167971 (CDR |options|) + (CDR G167971)) + (|option| NIL)) + ((OR (ATOM G167971) + (PROGN + (SETQ |option| (CAR G167971)) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((AND (PAIRP |option|) + (EQ (QCAR |option|) + '|break|)) + '|skip|) + ('T + (SPADLET |msg| + (CAR |option|)) + (SPADLET |class| + (CADR |option|)) + (SPADLET |var| + (CADDR |option|)) + (SPADLET |valuesOrFunction| + (CADDDR |option|)) + (|htSay| + (MAKESTRING + "\\newline\\tab{22}") + |msg| + (MAKESTRING "\\tab{80}")) + (|htSystemVariables,functionTail| + |name| |class| |var| + |valuesOrFunction|))))))))) + ('T (SPADLET |val| (|eval| |variable|)) + (|htSystemVariables,displayOptions| + |name| |key| |variable| |val| + |options|))))))) + (|htSay| (MAKESTRING "\\endmenu")) (|htShowPage|))))))) + +;htSetSystemVariableKind(htPage,[variable,name,fun]) == +; value := htpLabelInputString(htPage,name) +; if STRINGP value and fun then value := FUNCALL(fun,value) +;--SCM::what to do??? if not FIXP value then userError ??? +; SET(variable,value) +; htSystemVariables () + +(DEFUN |htSetSystemVariableKind| (|htPage| G168009) + (PROG (|variable| |name| |fun| |value|) + (RETURN + (PROGN + (SPADLET |variable| (CAR G168009)) + (SPADLET |name| (CADR G168009)) + (SPADLET |fun| (CADDR G168009)) + (SPADLET |value| (|htpLabelInputString| |htPage| |name|)) + (COND + ((AND (STRINGP |value|) |fun|) + (SPADLET |value| (FUNCALL |fun| |value|)))) + (SET |variable| |value|) + (|htSystemVariables|))))) + +;htSetSystemVariable(htPage,[name,value]) == +; value := +; value = 'on => true +; value = 'off => nil +; value +; SET(name,value) +; htSystemVariables () + +(DEFUN |htSetSystemVariable| (|htPage| G168030) + (declare (ignore |htPage|)) + (PROG (|name| |value|) + (RETURN + (PROGN + (SPADLET |name| (CAR G168030)) + (SPADLET |value| (CADR G168030)) + (SPADLET |value| + (COND + ((BOOT-EQUAL |value| '|on|) 'T) + ((BOOT-EQUAL |value| '|off|) NIL) + ('T |value|))) + (SET |name| |value|) + (|htSystemVariables|))))) + +;htGloss(pattern) == htGlossPage(nil,dbNonEmptyPattern pattern or '"*",true) + +(DEFUN |htGloss| (|pattern|) + (|htGlossPage| NIL + (OR (|dbNonEmptyPattern| |pattern|) (MAKESTRING "*")) 'T)) + +;htGlossPage(htPage,pattern,tryAgain?) == +; $wildCard: local := char '_* +; pattern = '"*" => downlink 'GlossaryPage +; filter := pmTransFilter pattern +; grepForm := mkGrepPattern(filter,'none) +; $key: local := 'none +; results := applyGrep(grepForm,'gloss) +; --pathname := STRCONC('"/tmp/",PNAME resultFile,'".text.", getEnv '"SPADNUM") +; --instream := MAKE_-INSTREAM pathname +; defstream := MAKE_-INSTREAM STRCONC(getEnv '"AXIOM",'"/algebra/glossdef.text") +; lines := gatherGlossLines(results,defstream) +; -- OBEY STRCONC('"rm -f ", pathname) +; --PROBE_-FILE(pathname) and DELETE_-FILE(pathname) +; --SHUT instream +; heading := +; pattern = '"" => '"Glossary" +; null lines => ['"No glossary items match {\em ",pattern,'"}"] +; ['"Glossary items matching {\em ",pattern,'"}"] +; null lines => +; tryAgain? and #pattern > 0 => +; (pattern.(k := MAXINDEX(pattern))) = char 's => +; htGlossPage(htPage,SUBSTRING(pattern,0,k),true) +; UPPER_-CASE_-P pattern.0 => +; htGlossPage(htPage,DOWNCASE pattern,false) +; errorPage(htPage,['"Sorry",nil,['"\centerline{",:heading,'"}"]]) +; errorPage(htPage,['"Sorry",nil,['"\centerline{",:heading,'"}"]]) +; htInitPageNoScroll(nil,heading) +; htSay('"\beginscroll\beginmenu") +; for line in lines repeat +; tick := charPosition($tick,line,1) +; htSay('"\item{\em \menuitemstyle{}}\tab{0}{\em ",escapeString SUBSTRING(line,0,tick),'"} ",SUBSTRING(line,tick + 1,nil)) +; htSay '"\endmenu " +; htSay '"\endscroll\newline " +; htMakePage [['bcLinks,['"Search",'"",'htGlossSearch,nil]]] +; htSay '" for glossary entry matching " +; htMakePage [['bcStrings, [24,'"*",'filter,'EM]]] +; htShowPageNoScroll() + +(DEFUN |htGlossPage| (|htPage| |pattern| |tryAgain?|) + (PROG (|$wildCard| |$key| |filter| |grepForm| |results| |defstream| + |lines| |heading| |k| |tick|) + (DECLARE (SPECIAL |$wildCard| |$key| |$tick|)) + (RETURN + (SEQ (PROGN + (SPADLET |$wildCard| (|char| '*)) + (COND + ((BOOT-EQUAL |pattern| (MAKESTRING "*")) + (|downlink| '|GlossaryPage|)) + ('T (SPADLET |filter| (|pmTransFilter| |pattern|)) + (SPADLET |grepForm| (|mkGrepPattern| |filter| '|none|)) + (SPADLET |$key| '|none|) + (SPADLET |results| (|applyGrep| |grepForm| '|gloss|)) + (SPADLET |defstream| + (MAKE-INSTREAM + (STRCONC (|getEnv| (MAKESTRING "AXIOM")) + (MAKESTRING + "/algebra/glossdef.text")))) + (SPADLET |lines| + (|gatherGlossLines| |results| |defstream|)) + (SPADLET |heading| + (COND + ((BOOT-EQUAL |pattern| (MAKESTRING "")) + (MAKESTRING "Glossary")) + ((NULL |lines|) + (CONS (MAKESTRING + "No glossary items match {\\em ") + (CONS |pattern| + (CONS (MAKESTRING "}") NIL)))) + ('T + (CONS (MAKESTRING + "Glossary items matching {\\em ") + (CONS |pattern| + (CONS (MAKESTRING "}") NIL)))))) + (COND + ((NULL |lines|) + (COND + ((AND |tryAgain?| (> (|#| |pattern|) 0)) + (COND + ((BOOT-EQUAL + (ELT |pattern| + (SPADLET |k| (MAXINDEX |pattern|))) + (|char| '|s|)) + (|htGlossPage| |htPage| + (SUBSTRING |pattern| 0 |k|) 'T)) + ((UPPER-CASE-P (ELT |pattern| 0)) + (|htGlossPage| |htPage| (DOWNCASE |pattern|) + NIL)) + ('T + (|errorPage| |htPage| + (CONS (MAKESTRING "Sorry") + (CONS NIL + (CONS + (CONS (MAKESTRING "\\centerline{") + (APPEND |heading| + (CONS (MAKESTRING "}") NIL))) + NIL))))))) + ('T + (|errorPage| |htPage| + (CONS (MAKESTRING "Sorry") + (CONS NIL + (CONS + (CONS + (MAKESTRING "\\centerline{") + (APPEND |heading| + (CONS (MAKESTRING "}") NIL))) + NIL))))))) + ('T (|htInitPageNoScroll| NIL |heading|) + (|htSay| (MAKESTRING "\\beginscroll\\beginmenu")) + (DO ((G168058 |lines| (CDR G168058)) + (|line| NIL)) + ((OR (ATOM G168058) + (PROGN (SETQ |line| (CAR G168058)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |tick| + (|charPosition| |$tick| + |line| 1)) + (|htSay| (MAKESTRING + "\\item{\\em \\menuitemstyle{}}\\tab{0}{\\em ") + (|escapeString| + (SUBSTRING |line| 0 |tick|)) + (MAKESTRING "} ") + (SUBSTRING |line| + (PLUS |tick| 1) NIL)))))) + (|htSay| (MAKESTRING "\\endmenu ")) + (|htSay| (MAKESTRING "\\endscroll\\newline ")) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS + (CONS (MAKESTRING "Search") + (CONS (MAKESTRING "") + (CONS '|htGlossSearch| + (CONS NIL NIL)))) + NIL)) + NIL)) + (|htSay| (MAKESTRING + " for glossary entry matching ")) + (|htMakePage| + (CONS (CONS '|bcStrings| + (CONS + (CONS 24 + (CONS (MAKESTRING "*") + (CONS '|filter| (CONS 'EM NIL)))) + NIL)) + NIL)) + (|htShowPageNoScroll|)))))))))) + +;gatherGlossLines(results,defstream) == +; acc := nil +; for keyline in results repeat +; --keyline := READLINE instream +; n := charPosition($tick,keyline,0) +; keyAndTick := SUBSTRING(keyline,0,n + 1) +; byteAddress := string2Integer SUBSTRING(keyline,n + 1,nil) +; FILE_-POSITION(defstream,byteAddress) +; line := READLINE defstream +; k := charPosition($tick,line,1) +; pointer := SUBSTRING(line,0,k) +; def := SUBSTRING(line,k + 1,nil) +; xtralines := nil +; while not EOFP defstream and (x := READLINE defstream) and +; (j := charPosition($tick,x,1)) and (nextPointer := SUBSTRING(x,0,j)) +; and (nextPointer = pointer) repeat +; xtralines := [SUBSTRING(x,j + 1,nil),:xtralines] +; acc := [STRCONC(keyAndTick,def, "STRCONC"/NREVERSE xtralines),:acc] +; REVERSE acc + +(DEFUN |gatherGlossLines| (|results| |defstream|) + (PROG (|n| |keyAndTick| |byteAddress| |line| |k| |pointer| |def| |x| + |j| |nextPointer| |xtralines| |acc|) + (declare (special |$tick|)) + (RETURN + (SEQ (PROGN + (SPADLET |acc| NIL) + (DO ((G168098 |results| (CDR G168098)) + (|keyline| NIL)) + ((OR (ATOM G168098) + (PROGN (SETQ |keyline| (CAR G168098)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |n| + (|charPosition| |$tick| |keyline| + 0)) + (SPADLET |keyAndTick| + (SUBSTRING |keyline| 0 + (PLUS |n| 1))) + (SPADLET |byteAddress| + (|string2Integer| + (SUBSTRING |keyline| (PLUS |n| 1) + NIL))) + (FILE-POSITION |defstream| |byteAddress|) + (SPADLET |line| (READLINE |defstream|)) + (SPADLET |k| + (|charPosition| |$tick| |line| 1)) + (SPADLET |pointer| + (SUBSTRING |line| 0 |k|)) + (SPADLET |def| + (SUBSTRING |line| (PLUS |k| 1) + NIL)) + (SPADLET |xtralines| NIL) + (DO () + ((NULL (AND (NULL (EOFP |defstream|)) + (SPADLET |x| + (READLINE |defstream|)) + (SPADLET |j| + (|charPosition| |$tick| |x| 1)) + (SPADLET |nextPointer| + (SUBSTRING |x| 0 |j|)) + (BOOT-EQUAL |nextPointer| + |pointer|))) + NIL) + (SEQ (EXIT + (SPADLET |xtralines| + (CONS + (SUBSTRING |x| (PLUS |j| 1) NIL) + |xtralines|))))) + (SPADLET |acc| + (CONS + (STRCONC |keyAndTick| |def| + (PROG (G168110) + (SPADLET G168110 "") + (RETURN + (DO + ((G168115 + (NREVERSE |xtralines|) + (CDR G168115)) + (G168081 NIL)) + ((OR (ATOM G168115) + (PROGN + (SETQ G168081 + (CAR G168115)) + NIL)) + G168110) + (SEQ + (EXIT + (SETQ G168110 + (STRCONC G168110 + G168081)))))))) + |acc|)))))) + (REVERSE |acc|)))))) + +;htGlossSearch(htPage,junk) == htGloss htpLabelInputString(htPage,'filter) + +(DEFUN |htGlossSearch| (|htPage| |junk|) + (declare (ignore |junk|)) + (|htGloss| (|htpLabelInputString| |htPage| '|filter|))) + +;htGreekSearch(filter) == +; ss := dbNonEmptyPattern filter +; s := pmTransFilter ss +; s is ['error,:.] => bcErrorPage s +; not s => errorPage(nil,[['"Missing search string"],nil, +; '"\vspace{2}\centerline{To select one of the greek letters:}\newline ", +; '"\centerline{{\em first} enter a search key into the input area}\newline ", +; '"\centerline{{\em then } move the mouse cursor to the work {\em search} and click}"]) +; filter := patternCheck s +; names := '(alpha beta gamma delta epsilon zeta eta theta iota kappa lambda mu nu pi) +; for x in names repeat +; superMatch?(filter,PNAME x) => matches := [x,:matches] +; nonmatches := [x,:nonmatches] +; matches := NREVERSE matches +; nonmatches := NREVERSE nonmatches +; htInitPage('"Greek Names",nil) +; null matches => +; htInitPage(['"Greek names matching search string {\em ",ss,'"}"],nil) +; 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}") +; htShowPage() +; htInitPage(['"Greek letters matching search string {\em ",ss,'"}"],nil) +; if nonmatches +; then htSay('"The greek letters that {\em match} your search string {\em ",ss,'"}:") +; else htSay('"Your search string {\em ",ss,"} matches all of the greek letters:") +; htSay('"{\em \table{") +; for x in matches repeat htSay('"{",x,'"}") +; htSay('"}}\vspace{1}") +; if nonmatches then +; htSay('"The greek letters that {\em do not match} your search string:{\em \table{") +; for x in nonmatches repeat htSay('"{",x,'"}") +; htSay('"}}") +; htShowPage() + +(DEFUN |htGreekSearch| (|filter|) + (PROG (|ss| |s| |names| |matches| |nonmatches|) + (RETURN + (SEQ (PROGN + (SPADLET |ss| (|dbNonEmptyPattern| |filter|)) + (SPADLET |s| (|pmTransFilter| |ss|)) + (COND + ((AND (PAIRP |s|) (EQ (QCAR |s|) '|error|)) + (|bcErrorPage| |s|)) + ((NULL |s|) + (|errorPage| NIL + (CONS (CONS (MAKESTRING "Missing search string") + NIL) + (CONS NIL + (CONS (MAKESTRING + "\\vspace{2}\\centerline{To select one of the greek letters:}\\newline ") + (CONS + (MAKESTRING + "\\centerline{{\\em first} enter a search key into the input area}\\newline ") + (CONS + (MAKESTRING + "\\centerline{{\\em then } move the mouse cursor to the work {\\em search} and click}") + NIL))))))) + ('T (SPADLET |filter| (|patternCheck| |s|)) + (SPADLET |names| + '(|alpha| |beta| |gamma| |delta| |epsilon| + |zeta| |eta| |theta| |iota| |kappa| + |lambda| |mu| |nu| |pi|)) + (DO ((G168149 |names| (CDR G168149)) (|x| NIL)) + ((OR (ATOM G168149) + (PROGN (SETQ |x| (CAR G168149)) NIL)) + NIL) + (SEQ (EXIT (COND + ((|superMatch?| |filter| (PNAME |x|)) + (SPADLET |matches| + (CONS |x| |matches|))) + ('T + (SPADLET |nonmatches| + (CONS |x| |nonmatches|))))))) + (SPADLET |matches| (NREVERSE |matches|)) + (SPADLET |nonmatches| (NREVERSE |nonmatches|)) + (|htInitPage| (MAKESTRING "Greek Names") NIL) + (COND + ((NULL |matches|) + (|htInitPage| + (CONS (MAKESTRING + "Greek names matching search string {\\em ") + (CONS |ss| (CONS (MAKESTRING "}") NIL))) + NIL) + (|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}|) + (|htShowPage|)) + ('T + (|htInitPage| + (CONS (MAKESTRING + "Greek letters matching search string {\\em ") + (CONS |ss| (CONS (MAKESTRING "}") NIL))) + NIL) + (COND + (|nonmatches| + (|htSay| (MAKESTRING + "The greek letters that {\\em match} your search string {\\em ") + |ss| (MAKESTRING "}:"))) + ('T + (|htSay| (MAKESTRING "Your search string {\\em ") + |ss| + '|} matches all of the greek letters:|))) + (|htSay| (MAKESTRING "{\\em \\table{")) + (DO ((G168158 |matches| (CDR G168158)) + (|x| NIL)) + ((OR (ATOM G168158) + (PROGN (SETQ |x| (CAR G168158)) NIL)) + NIL) + (SEQ (EXIT (|htSay| (MAKESTRING "{") |x| + (MAKESTRING "}"))))) + (|htSay| (MAKESTRING "}}\\vspace{1}")) + (COND + (|nonmatches| + (|htSay| (MAKESTRING + "The greek letters that {\\em do not match} your search string:{\\em \\table{")) + (DO ((G168167 |nonmatches| (CDR G168167)) + (|x| NIL)) + ((OR (ATOM G168167) + (PROGN + (SETQ |x| (CAR G168167)) + NIL)) + NIL) + (SEQ (EXIT (|htSay| (MAKESTRING "{") |x| + (MAKESTRING "}"))))) + (|htSay| (MAKESTRING "}}")))) + (|htShowPage|)))))))))) + +;htTextSearch(filter) == +; s := pmTransFilter dbNonEmptyPattern filter +; s is ['error,:.] => bcErrorPage s +; not s => errorPage(nil,[['"Missing search string"],nil, +; '"\vspace{2}\centerline{To select one of the lines of text:}\newline ", +; '"\centerline{{\em first} enter a search key into the input area}\newline ", +; '"\centerline{{\em then } move the mouse cursor to the work {\em search} and click}"]) +; filter := s +; lines := ['"{{\em Fruit flies} *like* a {\em banana and califlower ears.}}", +; '"{{\em Sneak Sears Silas with Savings Snatch}}"] +; for x in lines repeat +; superMatch?(filter,x) => matches := [x,:matches] +; nonmatches := [x,:nonmatches] +; matches := NREVERSE matches +; nonmatches := NREVERSE nonmatches +; htInitPage('"Text Matches",nil) +; null matches => +; htInitPage(['"Lines matching search string {\em ",s,'"}"],nil) +; htSay("\vspace{2}\centerline{Sorry, but no lines match your search string}\centerline{{\em ",s,"}}\centerline{Click on the up-arrow to try again}") +; htShowPage() +; htInitPage(['"Lines matching search string {\em ",s,'"}"],nil) +; if nonmatches +; then htSay('"The lines that {\em match} your search string {\em ",s,'"}:") +; else htSay('"Your search string {\em ",s,"} matches both lines:") +; htSay('"{\em \table{") +; for x in matches repeat htSay('"{",x,'"}") +; htSay('"}}\vspace{1}") +; if nonmatches then +; htSay('"The line that {\em does not match} your search string:{\em \table{") +; for x in nonmatches repeat htSay('"{",x,'"}") +; htSay('"}}") +; htShowPage() + +(DEFUN |htTextSearch| (|filter|) + (PROG (|s| |lines| |matches| |nonmatches|) + (RETURN + (SEQ (PROGN + (SPADLET |s| + (|pmTransFilter| (|dbNonEmptyPattern| |filter|))) + (COND + ((AND (PAIRP |s|) (EQ (QCAR |s|) '|error|)) + (|bcErrorPage| |s|)) + ((NULL |s|) + (|errorPage| NIL + (CONS (CONS (MAKESTRING "Missing search string") + NIL) + (CONS NIL + (CONS (MAKESTRING + "\\vspace{2}\\centerline{To select one of the lines of text:}\\newline ") + (CONS + (MAKESTRING + "\\centerline{{\\em first} enter a search key into the input area}\\newline ") + (CONS + (MAKESTRING + "\\centerline{{\\em then } move the mouse cursor to the work {\\em search} and click}") + NIL))))))) + ('T (SPADLET |filter| |s|) + (SPADLET |lines| + (CONS (MAKESTRING + "{{\\em Fruit flies} *like* a {\\em banana and califlower ears.}}") + (CONS (MAKESTRING + "{{\\em Sneak Sears Silas with Savings Snatch}}") + NIL))) + (DO ((G168191 |lines| (CDR G168191)) (|x| NIL)) + ((OR (ATOM G168191) + (PROGN (SETQ |x| (CAR G168191)) NIL)) + NIL) + (SEQ (EXIT (COND + ((|superMatch?| |filter| |x|) + (SPADLET |matches| + (CONS |x| |matches|))) + ('T + (SPADLET |nonmatches| + (CONS |x| |nonmatches|))))))) + (SPADLET |matches| (NREVERSE |matches|)) + (SPADLET |nonmatches| (NREVERSE |nonmatches|)) + (|htInitPage| (MAKESTRING "Text Matches") NIL) + (COND + ((NULL |matches|) + (|htInitPage| + (CONS (MAKESTRING + "Lines matching search string {\\em ") + (CONS |s| (CONS (MAKESTRING "}") NIL))) + NIL) + (|htSay| '|\\vspace{2}\\centerline{Sorry, but no lines match your search string}\\centerline{{\\em | + |s| + '|}}\\centerline{Click on the up-arrow to try again}|) + (|htShowPage|)) + ('T + (|htInitPage| + (CONS (MAKESTRING + "Lines matching search string {\\em ") + (CONS |s| (CONS (MAKESTRING "}") NIL))) + NIL) + (COND + (|nonmatches| + (|htSay| (MAKESTRING + "The lines that {\\em match} your search string {\\em ") + |s| (MAKESTRING "}:"))) + ('T + (|htSay| (MAKESTRING "Your search string {\\em ") + |s| '|} matches both lines:|))) + (|htSay| (MAKESTRING "{\\em \\table{")) + (DO ((G168200 |matches| (CDR G168200)) + (|x| NIL)) + ((OR (ATOM G168200) + (PROGN (SETQ |x| (CAR G168200)) NIL)) + NIL) + (SEQ (EXIT (|htSay| (MAKESTRING "{") |x| + (MAKESTRING "}"))))) + (|htSay| (MAKESTRING "}}\\vspace{1}")) + (COND + (|nonmatches| + (|htSay| (MAKESTRING + "The line that {\\em does not match} your search string:{\\em \\table{")) + (DO ((G168209 |nonmatches| (CDR G168209)) + (|x| NIL)) + ((OR (ATOM G168209) + (PROGN + (SETQ |x| (CAR G168209)) + NIL)) + NIL) + (SEQ (EXIT (|htSay| (MAKESTRING "{") |x| + (MAKESTRING "}"))))) + (|htSay| (MAKESTRING "}}")))) + (|htShowPage|)))))))))) + +;htTutorialSearch pattern == +; s := dbNonEmptyPattern pattern or return +; errorPage(nil,['"Empty search key",nil,'"\vspace{3}\centerline{You must enter some search string"]) +; s := mkUnixPattern s +; source := '"$AXIOM/doc/hypertex/pages/ht.db" +; target :='"/tmp/temp.text.$SPADNUM" +; OBEY STRCONC('"$AXIOM/lib/hthits",'" _"",s,'"_" ",source,'" > ",target) +; lines := dbReadLines 'temp +; htInitPageNoScroll(nil,['"Tutorial Pages mentioning {\em ",pattern,'"}"]) +; htSay('"\beginscroll\table{") +; for line in lines repeat +; [name,title,.] := dbParts(line,3,0) +; htSay ['"{\downlink{",title,'"}{",name,'"}}"] +; htSay '"}" +; htShowPage() + +(DEFUN |htTutorialSearch| (|pattern|) + (PROG (|s| |source| |target| |lines| |LETTMP#1| |name| |title|) + (RETURN + (SEQ (PROGN + (SPADLET |s| + (OR (|dbNonEmptyPattern| |pattern|) + (RETURN + (|errorPage| NIL + (CONS (MAKESTRING "Empty search key") + (CONS NIL + (CONS + (MAKESTRING + "\\vspace{3}\\centerline{You must enter some search string") + NIL))))))) + (SPADLET |s| (|mkUnixPattern| |s|)) + (SPADLET |source| + (MAKESTRING "$AXIOM/doc/hypertex/pages/ht.db")) + (SPADLET |target| (MAKESTRING "/tmp/temp.text.$SPADNUM")) + (OBEY (STRCONC (MAKESTRING "$AXIOM/lib/hthits") + (MAKESTRING " \"") |s| (MAKESTRING "\" ") + |source| (MAKESTRING " > ") |target|)) + (SPADLET |lines| (|dbReadLines| '|temp|)) + (|htInitPageNoScroll| NIL + (CONS (MAKESTRING "Tutorial Pages mentioning {\\em ") + (CONS |pattern| (CONS (MAKESTRING "}") NIL)))) + (|htSay| (MAKESTRING "\\beginscroll\\table{")) + (DO ((G168241 |lines| (CDR G168241)) (|line| NIL)) + ((OR (ATOM G168241) + (PROGN (SETQ |line| (CAR G168241)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |LETTMP#1| (|dbParts| |line| 3 0)) + (SPADLET |name| (CAR |LETTMP#1|)) + (SPADLET |title| (CADR |LETTMP#1|)) + (|htSay| (CONS (MAKESTRING "{\\downlink{") + (CONS |title| + (CONS (MAKESTRING "}{") + (CONS |name| + (CONS (MAKESTRING "}}") NIL)))))))))) + (|htSay| (MAKESTRING "}")) + (|htShowPage|)))))) + +;mkUnixPattern s == +; u := mkUpDownPattern s +; starPositions := REVERSE [i for i in 1..(-1 + MAXINDEX u) | u.i = $wild] +; for i in starPositions repeat +; u := STRCONC(SUBSTRING(u,0,i),'".*",SUBSTRING(u,i + 1,nil)) +; if u.0 ^= $wild then u := STRCONC('"[^a-zA-Z]",u) +; else u := SUBSTRING(u,1,nil) +; if u.(k := MAXINDEX u) ^= $wild then u := STRCONC(u,'"[^a-zA-Z]") +; else u := SUBSTRING(u,0,k) +; u + +(DEFUN |mkUnixPattern| (|s|) + (PROG (|starPositions| |k| |u|) + (declare (special |$wild|)) + (RETURN + (SEQ (PROGN + (SPADLET |u| (|mkUpDownPattern| |s|)) + (SPADLET |starPositions| + (REVERSE (PROG (G168264) + (SPADLET G168264 NIL) + (RETURN + (DO + ((G168270 + (PLUS (SPADDIFFERENCE 1) + (MAXINDEX |u|))) + (|i| 1 (QSADD1 |i|))) + ((QSGREATERP |i| G168270) + (NREVERSE0 G168264)) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL (ELT |u| |i|) + |$wild|) + (SETQ G168264 + (CONS |i| G168264))))))))))) + (DO ((G168277 |starPositions| (CDR G168277)) + (|i| NIL)) + ((OR (ATOM G168277) + (PROGN (SETQ |i| (CAR G168277)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |u| + (STRCONC (SUBSTRING |u| 0 |i|) + (MAKESTRING ".*") + (SUBSTRING |u| (PLUS |i| 1) NIL)))))) + (COND + ((NEQUAL (ELT |u| 0) |$wild|) + (SPADLET |u| (STRCONC (MAKESTRING "[^a-zA-Z]") |u|))) + ('T (SPADLET |u| (SUBSTRING |u| 1 NIL)))) + (COND + ((NEQUAL (ELT |u| (SPADLET |k| (MAXINDEX |u|))) |$wild|) + (SPADLET |u| (STRCONC |u| (MAKESTRING "[^a-zA-Z]")))) + ('T (SPADLET |u| (SUBSTRING |u| 0 |k|)))) + |u|))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}