path: root/src/interp/br-op2.boot

-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007, Gabriel Dos Reis.
-- 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)]