aboutsummaryrefslogtreecommitdiff
path: root/src/interp/br-op2.boot.pamphlet
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2007-09-20 03:58:10 +0000
committerdos-reis <gdr@axiomatics.org>2007-09-20 03:58:10 +0000
commit32d516cbb18276e5060749f85368c5a90346a0f4 (patch)
treeef3d9881bbdb62a623abc7af74384fd2aaa103f4 /src/interp/br-op2.boot.pamphlet
parent9b71e0a1f285fc207709cf8e90721160af299127 (diff)
downloadopen-axiom-32d516cbb18276e5060749f85368c5a90346a0f4.tar.gz
remove pamphlets - part 4
Diffstat (limited to 'src/interp/br-op2.boot.pamphlet')
-rw-r--r--src/interp/br-op2.boot.pamphlet790
1 files changed, 0 insertions, 790 deletions
diff --git a/src/interp/br-op2.boot.pamphlet b/src/interp/br-op2.boot.pamphlet
deleted file mode 100644
index 3fca3f73..00000000
--- a/src/interp/br-op2.boot.pamphlet
+++ /dev/null
@@ -1,790 +0,0 @@
-\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}
-
-<<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.
-
-@
-<<*>>=
-<<license>>
-
---====================> 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}