\documentclass{article} \usepackage{axiom} \title{\File{src/interp/br-op2.boot} Pamphlet} \author{The Axiom Team} \begin{document} \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. @ <<*>>= <> import '"br-op1" )package "BOOT" --====================> WAS br-op2.boot <================================ --======================================================================= -- Operation Description --======================================================================= displayDomainOp(htPage,which,origin,op,sig,predicate, doc,index,chooseFn,unexposed?,$generalSearch?) == -----------------------> OBSELETE $saturn => displayDomainOp1(htPage,which,origin,op,sig,predicate, doc,index,chooseFn,unexposed?,$generalSearch?) $chooseDownCaseOfType : local := true --see dbGetContrivedForm $whereList : local := nil $NumberList : local := '(i j k l m n i1 j1 k1 l1 m1 n1 i2 j2 k2 l2 m2 n2 i3 j3 k3 l3 m3 n3 i4 j4 k4 l4 m4 n4 ) $ElementList: local := '(x y z u v w x1 y1 z1 u1 v1 w1 x2 y2 z2 u2 v2 w2 x3 y3 z3 u3 v3 w3 x4 y4 z4 u4 v4 w4 ) $FunctionList:local := '(f g h d e F G H) $DomainList: local := '(D R S E T A B C M N P Q U V W) exactlyOneOpSig := null index conform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) or origin if $generalSearch? then $DomainList := rest $DomainList opform := which = '"attribute" => null sig => [op] [op,sig] which = '"constructor" => origin dbGetDisplayFormForOp(op,sig,doc) htSay('"\newline") if exactlyOneOpSig then htSay('"\menuitemstyle{}") else htMakePage [['bcLinks,['"\menuitemstyle{}",'"",chooseFn,which,index]]] htSay('"\tab{2}") op := IFCAR opform args := IFCDR opform ops := escapeSpecialChars STRINGIMAGE op n := #sig do n = 2 and LASSOC('Nud,PROPLIST op) => htSay(ops,'" {\em ",quickForm2HtString KAR args,'"}") n = 3 and LASSOC('Led,PROPLIST op) => htSay('"{\em ",quickForm2HtString KAR args,'"} ",ops,'" {\em ",quickForm2HtString KAR KDR args,'"}") if unexposed? and $includeUnexposed? then htSayUnexposed() htSaySaturn '"\unexposed{{\em " htSaySaturn ops htSaySaturn '"}" htSayStandard(ops) predicate='ASCONST or GETDATABASE(op,'NILADIC) or member(op,'(0 1)) => 'skip which = '"attribute" and null args => 'skip htSay('"(") if IFCAR args then htSay('"{\em ",quickForm2HtString IFCAR args,'"}") for x in IFCDR args repeat htSay('",{\em ",quickForm2HtString x,'"}") htSay('")") constring := form2HtString conform conname := first conform $conkind : local := htpProperty(htPage,'kind) -- a string e.g. "category" or STRINGIMAGE GETDATABASE(conname,'CONSTRUCTORKIND) $conlength : local := #constring $conform : local := conform $conargs : local := rest conform if which = '"operation" then $signature : local := MEMQ(conname,$Primitives) => nil CDAR getConstructorModemap conname --RDJ: this next line is necessary until compiler bug is fixed --that forgets to substitute #variables for t#variables; --check the signature for SegmentExpansionCategory, e.g. tvarlist := TAKE(# $conargs,$TriangleVariableList) $signature := SUBLISLIS($FormalMapVariableList,tvarlist,$signature) $sig := which = '"attribute" or which = '"constructor" => sig $conkind ^= '"package" => sig symbolsUsed := [x for x in rest conform | IDENTP x] $DomainList := SETDIFFERENCE($DomainList,symbolsUsed) getSubstSigIfPossible sig if member(which,'("operation" "constructor")) then $displayReturnValue: local := nil if args then htSay('"\newline") htSayStandard '"\tab{2}" htSay '"{\em Arguments:}" for a in args for t in rest $sig repeat htSayIndentRel(15,true) htSay('"{\em ",form2HtString(a),'"}, ") htSayValue t htSayIndentRel(-15,true) htSay('"\newline ") if first $sig then $displayReturnValue := true htSay('"\newline\tab{2}{\em Returns:}") htSayIndentRel(15) htSayValue first $sig htSayIndentRel(-15) htSay('"\newline ") if origin and ($generalSearch? or origin ^= conform) and opOf(origin)^=op then htSay('"\newline\tab{2}{\em Origin:}") htSayIndentRel(15) if not isExposedConstructor opOf origin and $includeUnexposed? then htSayUnexposed() bcConform(origin,true) htSayIndentRel(-15) if not MEMQ(predicate,'(T ASCONST)) then pred := sublisFormal(KDR conform,predicate) count := #pred htSay('"\newline\tab{2}{\em Conditions:}") for p in displayBreakIntoAnds SUBST($conform,"$",pred) repeat htSayIndentRel(15,count > 1) bcPred(p,$conform,true) htSayIndentRel(-15,count > 1) htSay('"\newline ") if $whereList then count := #$whereList htSay('"\newline\tab{2}{\em Where:}") if ASSOC("$",$whereList) then htSayIndentRel(15,true) htSayStandard '"{\em \$} is " htSaySaturn '"{\em \%} is " htSay $conkind = '"category" => '"of category " '"the domain " bcConform(conform,true,true) htSayIndentRel(-15,true) for [d,key,:t] in $whereList | d ^= "$" repeat htSayIndentRel(15,count > 1) htSay("{\em ",d,"} is ") htSayConstructor(key,sublisFormal(KDR conform,t)) htSayIndentRel(-15,count > 1) if doc and (doc ^= '"" and (doc isnt [d] or d ^= '"")) then htSay('"\newline\tab{2}{\em Description:}") htSayIndentRel(15) if doc = $charFauxNewline then htSay $charNewline else ndoc:= -- we are confused whether doc is a string or a list of strings CONSP doc => [SUBSTITUTE($charNewline, $charFauxNewline, i) for i in doc] SUBSTITUTE($charNewline, $charFauxNewline,doc) htSay ndoc htSayIndentRel(-15) if exactlyOneOpSig and (infoAlist := htpProperty(htPage,'infoAlist)) then displayInfoOp(htPage,infoAlist,op,sig) htSayIndentRel(n,:options) == -----------------> OBSELETE flag := IFCAR options m := ABSVAL n if flag then m := m + 2 htSay n > 0 => flag => ['"\indent{",STRINGIMAGE m,'"}\tab{-2}"] ['"\indent{",STRINGIMAGE m,'"}\tab{0}"] n < 0 => ['"\indent{0}\newline "] htSayConstructor(key,u) == u is ['CATEGORY,kind,:r] => htSay('"a ",kind,'" ") htSayExplicitExports(r) key = 'is => htSay '"the domain " bcConform(u,true) htSay key = 'is => '"the domain " kind := GETDATABASE(opOf u,'CONSTRUCTORKIND) kind = 'domain => '"an element of " '"a domain of " u is ['Join,:middle,r] => rest middle => htSay '"categories " bcConform(first middle,true) for x in rest middle repeat htSay '", " bcConform(x,true) r is ['CATEGORY,.,:r] => htSay '" and " htSayExplicitExports(r) htSay '" and " bcConform(r,true) htSay '"category " bcConform(first middle,true) r is ['CATEGORY,.,:r] => htSay '" " htSayExplicitExports(r) htSay '" and " bcConform(r,true) htSay(kind,'" ") bcConform(u,true) htSayExplicitExports r == htSay '"with explicit exports" $displayReturnValue => nil htSay '":" for x in r repeat htSay '"\newline " x is ['SIGNATURE,op,sig] => ops := escapeSpecialChars STRINGIMAGE op htMakePage [['bcLinks,[ops,'"",'oPage,ops]]] htSay '": " bcConform ['Mapping,:sig] x is ['ATTRIBUTE,a] => s := form2HtString a htMakePage [['bcLinks,[ops,'"",'aPage,s]]] x is ['IF,:.] => htSay('"{\em if ...}") systemError() displayBreakIntoAnds pred == pred is [op,:u] and member(op,'(and AND)) => u [pred] htSayValue t == t is ['Mapping,target,:source] => htSay('"a function from ") htSayTuple source htSay '" to " htSayArgument target t = '(Category) => htSay('"a category") t is [op,:.] and MEMQ(op,'(Join CATEGORY)) or constructor? opOf t => htSayConstructor(nil,t) htSay('"an element of domain ") htSayArgument t --continue for operations htSayArgument t == --called only for operations not for constructors null $signature => htSay ['"{\em ",t,'"}"] MEMQ(t, '(_$ _%)) => $conkind = '"category" and $conlength > 20 => $generalSearch? => htSay '"{\em D} of the origin category" addWhereList("$",'is,nil) htSayStandard '"{\em $}" htSaySaturn '"{\em \%}" htSayStandard '"{\em $}" htSaySaturn '"{\em \%}" not IDENTP t => bcConform(t,true) k := position(t,$conargs) if k > -1 then typeOfArg := (rest $signature).k addWhereList(t,'member,typeOfArg) htSay('"{\em ",t,'"}") addWhereList(id,kind,typ) == $whereList := insert([id,kind,:typ],$whereList) htSayTuple t == null t => htSay '"()" null rest t => htSayArgument first t htSay '"(" htSayArgument first t for d in rest t repeat htSay '"," htSayArgument d htSay '")" dbGetDisplayFormForOp(op,sig,doc) == dbGetFormFromDocumentation(op,sig,doc) or dbGetContrivedForm(op,sig) dbGetFormFromDocumentation(op,sig,x) == doc := (STRINGP x => x; first x) STRINGP doc and (stringPrefix?('"\spad{",doc) and (k := 6) or stringPrefix?('"\s{",doc) and (k := 3)) => n := charPosition($charRbrace,doc,k) s := SUBSTRING(doc,k,n - k) parse := ncParseFromString s parse is [=op,:.] and #parse = #sig => parse nil dbMakeContrivedForm(op,sig,:options) == $chooseDownCaseOfType : local := IFCAR options $NumberList : local := '(i j k l m n i1 j1 k1 l1 m1 n1 i2 j2 k2 l2 m2 n2 i3 j3 k3 l3 m3 n3 i4 j4 k4 l4 m4 n4 ) $ElementList: local := '(x y z u v w x1 y1 z1 u1 v1 w1 x2 y2 z2 u2 v2 w2 x3 y3 z3 u3 v3 w3 x4 y4 z4 u4 v4 w4 ) $FunctionList:local := '(f g h d e F G H) $DomainList: local := '(R S D E T A B C M N P Q U V W) dbGetContrivedForm(op,sig) dbGetContrivedForm(op,sig) == op = '"0" => [0] op = '"1" => [1] [op,:[dbChooseOperandName s for s in rest sig]] dbChooseOperandName(typ) == typ is ['Mapping,:.] => x := first $FunctionList $FunctionList := rest $FunctionList x name := opOf typ kind := name = "$" => 'domain GETDATABASE(name,'CONSTRUCTORKIND) s := PNAME opOf typ kind ^= 'category => anySubstring?('"Integer",s,0) or anySubstring?('"Number",s,0) => x := first $NumberList $NumberList := rest $NumberList x x := $chooseDownCaseOfType => y := DOWNCASE typ x := member(y,$ElementList) => y first $ElementList first $ElementList $ElementList := delete(x,$ElementList) x x := first $DomainList $DomainList := rest $DomainList x getSubstSigIfPossible sig == getSubstSignature sig or sig -- -- while (u := getSubstSignature sig) repeat -- sig := u -- sig fullSubstitute(x,y,z) == --substitutes deeply: x for y in list z z = y => x atom z => z [fullSubstitute(x,y,u) for u in z] getSubstCandidates sig == candidates := nil for x in sig for i in 1.. | x is [.,.,:.] repeat getSubstQualify(x,i,sig) => candidates := getSubstInsert(x,candidates) y := or/[getSubstQualify(y,i,sig) for y in rest x | y is [.,.,:.]] => candidates := insert(y,candidates) candidates getSubstSignature sig == candidates := getSubstCandidates sig null candidates => nil D := first $DomainList $DomainList := rest $DomainList winner := first candidates newsig := fullSubstitute(D,winner,sig) sig := null rest candidates => newsig count := NUMOFNODES newsig for x in rest candidates repeat trial := fullSubstitute(D,x,sig) trialCount := NUMOFNODES trial trialCount < count => newsig := trial count := trialCount winner := x newsig addWhereList(D,'is,winner) newsig getSubstQualify(x,i,sig) == or/[CONTAINED(x,y) for y in sig for j in 1.. | j ^= i] => x false getSubstInsert(x,candidates) == return insert(x,candidates) null candidates => [x] or/[CONTAINED(x,y) for y in candidates] => candidates y := or/[CONTAINED(y,x) for y in candidates] => SUBST(x,y,candidates) candidates --======================================================================= -- Who Uses --======================================================================= whoUsesOperation(htPage,which,key) == --see dbPresentOps key = 'filter => koaPageFilterByName(htPage,'whoUsesOperation) opAlist := htpProperty(htPage,'opAlist) conform := htpProperty(htPage,'conform) conargs := rest conform opl := nil for [op,:alist] in opAlist repeat for [sig,:.] in alist repeat opl := [[op,:SUBLISLIS($FormalMapVariableList,rest conform,sig)],:opl] opl := NREVERSE opl u := whoUses(opl,conform) prefix := pluralSay(#u,'"constructor uses",'"constructors use") suffix := opAlist is [[op1,.]] => ['" operation {\em ",escapeSpecialChars STRINGIMAGE op1,'":",form2HtString ['Mapping,:sig],'"}"] ['" these operations"] page := htInitPage([:prefix,:suffix],htCopyProplist htPage) nopAlist := nil for [name,:opsigList] in u repeat for opsig in opsigList repeat sofar := LASSOC(opsig,nopAlist) nopAlist := insertAlist(opsig,[name,:LASSOC(opsig,nopAlist)],nopAlist) usedList := nil for [pair := [op,:sig],:namelist] in nopAlist repeat ops := escapeSpecialChars STRINGIMAGE op usedList := [pair,:usedList] htSay('"Users of {\em ",ops,'": ") bcConform ['Mapping,:sublisFormal(conargs,sig)] htSay('"}\newline") bcConTable listSort(function GLESSEQP,REMDUP namelist) noOneUses := SETDIFFERENCE(opl,usedList) if #noOneUses > 0 then htSay('"No constructor uses the ") htSay #noOneUses = 1 => '"operation: " [#noOneUses,'" operations:"] htSay '"\newline " for [op,:sig] in noOneUses repeat htSay('"\tab{2}{\em ",escapeSpecialChars STRINGIMAGE op,'": ") bcConform ['Mapping,:sublisFormal(conargs,sig)] htSay('"}\newline") htSayStandard '"\endscroll " dbPresentOps(page,which,'usage) htShowPageNoScroll() whoUses(opSigList,conform) == opList := REMDUP ASSOCLEFT opSigList numOfArgsList := REMDUP [-1 + #sig for [.,:sig] in opSigList] acc := nil $conname : local := first conform domList := getUsersOfConstructor $conname hash := MAKE_-HASH_-TABLE() for name in allConstructors() | MEMQ(name,domList) repeat $infovec : local := dbInfovec name null $infovec => 'skip --category template := $infovec . 0 found := false opacc := nil for i in 7..MAXINDEX template repeat item := template . i item isnt [n,:op] or not MEMQ(op,opList) => 'skip index := n numvec := getCodeVector() numOfArgs := numvec . index null member(numOfArgs,numOfArgsList) => 'skip whereNumber := numvec.(index := index + 1) template . whereNumber isnt [= $conname,:.] => 'skip signumList := dcSig(numvec,index + 1,numOfArgs) opsig := or/[pair for (pair := [op1,:sig]) in opSigList | op1 = op and whoUsesMatch?(signumList,sig,nil)] => opacc := [opsig,:opacc] if opacc then acc := [[name,:opacc],:acc] acc whoUsesMatch?(signumList,sig,al) == #signumList = #sig and whoUsesMatch1?(signumList,sig,al) whoUsesMatch1?(signumList,sig,al) == signumList is [subject,:r] and sig is [pattern,:s] => x := LASSOC(pattern,al) => x = subject => whoUsesMatch1?(r,s,al) false pattern = '_$ => subject is [= $conname,:.] => whoUsesMatch1?(r,s,[['_$,:subject],:al]) false whoUsesMatch1?(r,s,[[pattern,:subject],:al]) true --======================================================================= -- Get Attribute/Operation Alist --======================================================================= koAttrs(conform,domname) == [conname,:args] := conform --asharpConstructorName? conname => nil --assumed 'category = GETDATABASE(conname,'CONSTRUCTORKIND) => koCatAttrs(conform,domname) $infovec: local := dbInfovec conname or return nil $predvec: local := $domain => $domain . 3 GETDATABASE(conname,'PREDICATES) u := [[a,:pred] for [a,:i] in $infovec . 2 | a ^= 'nil and (pred := sublisFormal(args,kTestPred i))] --------- CHECK for a = nil listSort(function GLESSEQP,fn u) where fn u == alist := nil for [a,:pred] in u repeat op := opOf a args := IFCDR a alist := insertAlist(op,insertAlist(args,[pred],LASSOC(op,alist)),alist) alist koOps(conform,domname,:options) == main where --returns alist of form ((op (sig . pred) ...) ...) main() == $packageItem: local := nil -- relatives? := IFCAR options ours := -- relatives? = 'onlyRelatives => nil fn(conform,domname) -- if relatives? then -- relatives := relativesOf(conform,domname) -- if domname then relatives := -- SUBLISLIS([domname,:rest domname],['_$,:rest conform],relatives) -- --kill all relatives that have a sharp variable remaining in them -- for x in relatives repeat -- or/[y for y in CDAR x | isSharpVar y] => 'skip -- acc := [x,:acc] -- relatives := NREVERSE acc -- for (pair := [pakform,:.]) in relatives repeat -- $packageItem := sublisFormal(rest conform,pair) -- ours := merge(fn(pakform,nil),ours) listSort(function GLESSEQP,trim ours) trim u == [pair for pair in u | IFCDR pair] fn(conform,domname) == conform := domname or conform [conname,:args] := conform subargs: local := args ----------> new <------------------ u := koCatOps(conform,domname) => u -- 'category = GETDATABASE(conname,'CONSTRUCTORKIND) => -- koCatOps(conform,domname) asharpConstructorName? opOf conform => nil ----------> new <------------------ $infovec: local := dbInfovec conname--------> removed 94/10/24 exposureTail := null $packageItem => '(NIL NIL) isExposedConstructor opOf conform => [conform,:'(T)] [conform,:'(NIL)] for [op,:u] in getOperationAlistFromLisplib conname repeat op1 := zeroOneConvert op acc := [[op1,:[[sig,npred,:exposureTail] for [sig,slot,pred,key,:.] in sublisFormal(subargs,u) | (key ^= 'Subsumed) and (npred := simpHasPred pred)]],:acc] acc merge(alist,alist1) == --alist1 takes precedence for [op,:al] in alist1 repeat u := LASSOC(op,alist) => for [sig,:item] in al | not LASSOC(sig,u) repeat u := insertAlist(sig,item,u) alist := insertAlist(op,u,DELASC(op,alist)) --add the merge of two alists alist := insertAlist(op,al,alist) --add the whole inner alist alist zeroOneConvert x == x = 'Zero => 0 x = 'One => 1 x kFormatSlotDomain x == fn formatSlotDomain x where fn x == atom x => x (op := CAR x) = '_$ => '_$ op = 'local => CADR x op = ":" => [":",CADR x,fn CADDR x] MEMQ(op,$Primitives) or constructor? op => [fn y for y in x] INTEGERP op => op op = 'QUOTE and atom CADR x => CADR x x koCatOps(conform,domname) == conname := opOf conform oplist := REVERSE GETDATABASE(conname,'OPERATIONALIST) oplist := sublisFormal(IFCDR domname or IFCDR conform ,oplist) --check below for INTEGERP key to avoid subsumed signatures [[zeroOneConvert op,:nalist] for [op,:alist] in oplist | nalist := koCatOps1(alist)] koCatOps1 alist == [x for item in alist | x := pair] where pair() == [sig,:r] := item null r => [sig,true] [key,:options] := r null (pred := IFCAR options) => IFCAR IFCDR options = 'ASCONST => [sig,'ASCONST] [sig,true] npred := simpHasPred pred => [sig,npred] false koCatAttrs(catform,domname) == $if: local := MAKE_-HASHTABLE 'ID catname := opOf catform koCatAttrsAdd(domname or catform,true) ancestors := ancestorsOf(catform,domname) for [conform,:pred] in ancestors repeat koCatAttrsAdd(conform,pred) hashTable2Alist $if hashTable2Alist tb == [[op,:HGET(tb,op)] for op in listSort(function GLESSEQP,HKEYS $if)] koCatAttrsAdd(catform,pred) == for [name,argl,:p] in CAR getConstructorExports catform repeat npred := quickAnd(pred,p) exists := HGET($if,name) if existingPred := LASSOC(argl,exists)_ then npred := quickOr(npred,existingPred) if not MEMQ(name,'(nil nothing)) _ then HPUT($if,name,[[argl,simpHasPred npred],:exists]) --======================================================================= -- Filter by Category --======================================================================= koaPageFilterByCategory(htPage,calledFrom) == opAlist := htpProperty(htPage,'opAlist) which := htpProperty(htPage,'which) page := htInitPageNoScroll(htCopyProplist htPage, dbHeading(opAlist,which,htpProperty(htPage,'heading))) htSay('"Select a category ancestor below or ") htMakePage [['bcLispLinks,['"filter",'"on:",calledFrom,'filter]]] htMakePage [['bcStrings, [13,'"",'filter,'EM]]] htSay('"\beginscroll ") conform := htpProperty(htPage,'conform) domname := htpProperty(htPage,'domname) ancestors := ASSOCLEFT ancestorsOf(conform,domname) htpSetProperty(page,'ancestors,listSort(function GLESSEQP,ancestors)) bcNameCountTable(ancestors,'form2HtString,'koaPageFilterByCategory1,true) htShowPage() dbHeading(items,which,heading,:options) == names? := IFCAR options count := names? => #items +/[#(rest x) for x in items] capwhich := capitalize which prefix := count < 2 => names? => pluralSay(count,STRCONC(capwhich," Name"),nil) pluralSay(count,capwhich,nil) names? => pluralSay(count,nil,STRCONC(capwhich," Names")) pluralSay(count,nil,pluralize capwhich) [:prefix,'" for ",:heading] koaPageFilterByCategory1(htPage,i) == ancestor := (htpProperty(htPage,'ancestors)) . i ancestorList := [ancestor,:ASSOCLEFT ancestorsOf(ancestor,nil)] newOpAlist := nil which := htpProperty(htPage,'which) opAlist := htpProperty(htPage,'opAlist) domname := htpProperty(htPage,'domname) conform := htpProperty(htPage,'conform) heading := htpProperty(htPage,'heading) docTable := dbDocTable(domname or conform) for [op,:alist] in opAlist repeat nalist := [[origin,:item] for item in alist | split] where split() == [sig,pred,:aux] := item u := dbGetDocTable(op,sig,docTable,which,aux) origin := IFCAR u doc := IFCDR u true for [origin,:item] in nalist | origin repeat member(origin,ancestorList) => newEntry := [item,:LASSOC(op,newOpAlist)] newOpAlist := insertAlist(op,newEntry,newOpAlist) falist := nil for [op,:alist] in newOpAlist repeat falist := [[op,:NREVERSE alist],:falist] htpSetProperty(htPage,'fromcat,['" from category {\sf ",form2HtString ancestor,'"}"]) dbShowOperationsFromConform(htPage,which,falist) --======================================================================= -- New code for search operation alist for exact matches --======================================================================= opPageFast opAlist == --called by oSearch htPage := htInitPage(nil,nil) htpSetProperty(htPage,'opAlist,opAlist) htpSetProperty(htPage,'expandOperations,'lists) which := '"operation" --dbResetOpAlistCondition(htPage,which,opAlist) dbShowOp1(htPage,opAlist,which,'names) opPageFastPath opstring == --return nil x := STRINGIMAGE opstring charPosition(char '_*,x,0) < #x => nil --quit if name has * in it op := (STRINGP x => INTERN x; x) mmList := getAllModemapsFromDatabase(op,nil) or return nil opAlist := [[op,:[item for mm in mmList]]] where item() == [predList, origin, sig] := modemap2Sig(op, mm) predicate := predList and MKPF(predList,'AND) exposed? := isExposedConstructor opOf origin [sig, predicate, origin, exposed?] opAlist modemap2Sig(op,mm) == [dcSig, conds] := mm [dc, :sig] := dcSig partial? := conds is ['partial,:r] => conds := r false condlist := modemap2SigConds conds [origin, vlist, flist] := getDcForm(dc, condlist) or return nil subcondlist := SUBLISLIS(flist, vlist, condlist) [predList,vlist, flist] := getSigSubst(subcondlist, nil, vlist, flist) if partial? then target := dcSig . 1 ntarget := ['Union, target, '"failed"] dcSig := SUBST(ntarget, target, dcSig) alist := findSubstitutionOrder? pairlis(vlist, flist) or systemError() predList := substInOrder(alist, predList) nsig := substInOrder(alist, sig) if hasPatternVar nsig or hasPatternVar predList then pp '"--------------" pp op pp predList pp nsig pp mm $badStack := [[op, mm], :$badStack] --pause nsig [predList, origin, SUBST("%", origin, nsig)] modemap2SigConds conds == conds is ['OR,:r] => modemap2SigConds first r conds is ['AND,:r] => r [conds] hasPatternVar x == IDENTP x and (x ^= "**") => isPatternVar x atom x => false or/[hasPatternVar y for y in x] getDcForm(dc, condlist) == [ofWord,id,cform] := or/[x for x in condlist | x is [k,=dc,:.] and MEMQ(k, '(ofCategory isDomain))] or return nil conform := getConstructorForm opOf cform ofWord = 'ofCategory => [conform, ["*1", :rest cform], ["%", :rest conform]] ofWord = 'isDomain => [conform, ["*1", :rest cform], ["%", :rest conform]] systemError() getSigSubst(u, pl, vl, fl) == u is [item, :r] => item is ['AND,:s] => [pl, vl, fl] := getSigSubst(s, pl, vl, fl) getSigSubst(r, pl, vl, fl) [key, v, f] := item key = 'isDomain => getSigSubst(r, pl, [v, :vl], [f, :fl]) key = 'ofCategory => getSigSubst(r, pl, ['D, :vl], [f, :fl]) key = 'ofType => getSigSubst(r, pl, vl, fl) key = 'has => getSigSubst(r, [item, :pl], vl, fl) key = 'not => getSigSubst(r, [item, :pl], vl, fl) systemError() [pl, vl, fl] pairlis(u,v) == null u or null v => nil [[first u,:first v],:pairlis(rest u, rest v)] @ \eject \begin{thebibliography}{99} \bibitem{1} nothing \end{thebibliography} \end{document}