)abbrev category PARTSET PartitionedSet
++ Sets whose elements are grouped into equivalence classes by a mapping
++ Author: Bill Page
++ Date Created: 20 March 2015
++ Description:
++   A partitioned set is a set whose elements have an integer as part
++   of their structure. This integer assigns each element to a "bin".
PartitionedSet : Category == SetCategory with
  position   : % -> NonNegativeInteger
    ++ position(x) returns the integer n associated to x.
  setPosition : (%, NonNegativeInteger) -> Void
    ++ setPosition(x, n) associates the integer n to x.

)abbrev domain KERNEL Kernel
++ Operators applied to elements of a set
++ Author: Manuel Bronstein
++ Date Created: 22 March 1988
++ Date Last Updated: 10 August 1994
++ Description:
++ A kernel over a set S is an operator applied to a given list
++ of arguments from S.
Kernel(S : Comparable) : Exports == Implementation where
  O  ==> OutputForm
  N  ==> NonNegativeInteger
  OP ==> BasicOperator

  Exports ==> Join(PartitionedSet, OrderedSet, Patternable S) with
    name    : % -> Symbol
      ++ name(op(a1, ..., an)) returns the name of op.
    operator : % -> OP
      ++ operator(op(a1, ..., an)) returns the operator op.
    argument : % -> List S
      ++ argument(op(a1, ..., an)) returns \spad{[a1, ..., an]}.
    height  : % -> N
      ++ height(k) returns the nesting level of k.
    kernel  : (OP, List S, N) -> %
      ++ kernel(op, [a1, ..., an], m) returns the kernel \spad{op(a1, ..., an)}
      ++ of nesting level m.
      ++ Error: if op is k-ary for some k not equal to n.
    kernel  : Symbol -> %
      ++ kernel(x) returns x viewed as a kernel.
    symbolIfCan : % -> Union(Symbol, "failed")
      ++ symbolIfCan(k) returns k viewed as a symbol if k is a symbol, and
      ++ "failed" otherwise.
    is?     : (%, OP) -> Boolean
      ++ is?(op(a1, ..., an), f) tests if op = f.
    is?     : (%, Symbol) -> Boolean
      ++ is?(op(a1, ..., an), s) tests if the name of op is s.
    if S has ConvertibleTo InputForm then ConvertibleTo InputForm

  Implementation ==> add

    operator(k : %) : OP == SPAD_-KERNEL_-OP(k)$Lisp
    argument(k : %) : List S == SPAD_-KERNEL_-ARG(k)$Lisp
    height(k) == SPAD_-KERNEL_-NEST(k)$Lisp
    position(k : %) : N == SPAD_-KERNEL_-POSIT(k)$Lisp
    setPosition(k, n) == SET_-SPAD_-KERNEL_-POSIT(k, n)$Lisp
    mkKer(o : OP, a : List S, n : N) : % == makeSpadKernel(o, a, n)$Lisp

    SYMBOL  := '%symbol
    PMPRED  := '%pmpredicate
    PMOPT   := '%pmoptional
    PMMULT  := '%pmmultiple
    PMCONST := '%pmconstant
    SPECIALDISP  := '%specialDisp
    SPECIALEQUAL := '%specialEqual
    SPECIALINPUT := '%specialInput

    import from XHashTable(List N,Boolean)
    cache:XHashTable(List N,Boolean):=table()
    bin:N:=0

    preds : OP      -> List Any

    is?(k : %, s : Symbol) == is?(operator k, s)
    is?(k : %, o : OP)     == (operator k) = o
    name k             == name operator k
    kernel s           == kernel(assert(operator(s, 0), SYMBOL), nil(), 1)

    preds o ==
      (u := property(o, PMPRED)) case "failed" => nil()
      (u::None) pretend List(Any)

    symbolIfCan k ==
      has?(operator k, SYMBOL) => name operator k
      "failed"

    kerEqual(k1:%,k2:%):Boolean ==
      height(k1)   ~= height(k2)   => false
      operator(k1) ~= operator(k2) => false
      (n1 := #(argument k1)) ~= (n2 := #(argument k2)) => false
      ((func := property(operator k1, SPECIALEQUAL)) case None) =>
        (((func::None) pretend ((%, %) -> Boolean)) (k1, k2))
      for x1 in argument(k1) for x2 in argument(k2) repeat
        x1 ~= x2 => return false
      true

    k1 = k2 ==
      p1:=position(k1); p2:=position(k2)
      p1=p2 => true
      if p1<p2 then
        eq:=search([p1,p2],cache)
        if eq case "failed" then
          eq:=kerEqual(k1,k2)
          if (cache([p1,p2]):=eq::Boolean) then setPosition(k2,p1)
      else
        eq:=search([p2,p1],cache)
        if eq case "failed" then
          eq:=kerEqual(k2,k1)
          if (cache([p2,p1]):=eq::Boolean) then setPosition(k1,p2)
      eq::Boolean

    k1 < k2 ==
      -- We have to do this the hard way
      height(k1)   ~= height(k2)   => height(k1)   < height(k2)
      operator(k1) ~= operator(k2) => operator(k1) < operator(k2)
      (n1 := #(argument k1)) ~= (n2 := #(argument k2)) => n1 < n2
      ((func := property(operator k1, SPECIALEQUAL)) case None) and
        (((func::None) pretend ((%, %) -> Boolean)) (k1, k2)) => false
      for x1 in argument(k1) for x2 in argument(k2) repeat
        -- This should not be "mathematical" inequality!
        --x1 ~= x2 => return smaller?(x1, x2)
        smaller?(x1, x2) => return true
        smaller?(x2, x1) => return false
      false

    kernel(fn, x, n) ==
      ((u := arity fn) case N) and (#x ~= u::N)
                                    => error "Wrong number of arguments"
      k:=mkKer(fn, x, n)
      setPosition(k,bin:=bin+1)
      k

    -- SPECIALDISP contains a map List S -> OutputForm
    -- it is used when the converting the arguments first is not good,
    -- for instance with formal derivatives.
    coerce(k : %) : OutputForm ==
      (v := symbolIfCan k) case Symbol => v::Symbol::OutputForm
      (f := property(o := operator k, SPECIALDISP)) case None =>
        ((f::None) pretend (List S -> OutputForm)) (argument k)
      l := [x::OutputForm for x in argument k]$List(OutputForm)
      (u := display o) case "failed" => prefix(name(o)::OutputForm, l)
      (u::(List OutputForm -> OutputForm)) l

    if S has ConvertibleTo InputForm then
      convert(k : %) : InputForm ==
        (v := symbolIfCan k) case Symbol => convert(v::Symbol)@InputForm
        (f := property(o := operator k, SPECIALINPUT)) case None =>
          ((f::None) pretend (List S -> InputForm)) (argument k)
        l := [convert x for x in argument k]$List(InputForm)
        (u := input operator k) case "failed" =>
          convert concat(convert name operator k, l)
        (u::(List InputForm -> InputForm)) l

    if S has ConvertibleTo Pattern Integer then
      convert(k : %) : Pattern(Integer) ==
        o := operator k
        (v := symbolIfCan k) case Symbol =>
          s  := patternVariable(v::Symbol,
                      has?(o, PMCONST), has?(o, PMOPT), has?(o, PMMULT))
          empty?(l := preds o) => s
          setPredicates(s, l)
        o [convert x for x in argument(k)]$List(Pattern Integer)

    if S has ConvertibleTo Pattern Float then
      convert(k : %) : Pattern(Float) ==
        o := operator k
        (v := symbolIfCan k) case Symbol =>
          s  := patternVariable(v::Symbol,
                      has?(o, PMCONST), has?(o, PMOPT), has?(o, PMMULT))
          empty?(l := preds o) => s
          setPredicates(s, l)
        o [convert x for x in argument(k)]$List(Pattern Float)

)abbrev package KERNEL2 KernelFunctions2
++ Description:
++ This package exports some auxiliary functions on kernels
KernelFunctions2(R : Comparable, S : Comparable) : with
  constantKernel : R -> Kernel S
        ++ constantKernel(r) \undocumented
  constantIfCan : Kernel S -> Union(R, "failed")
        ++ constantIfCan(k) \undocumented

 == add
  import from BasicOperatorFunctions1(R)

  constantKernel r == kernel(constantOperator r, nil(), 1)
  constantIfCan k  == constantOpIfCan operator k

--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.

-- SPAD files for the functional world should be compiled in the
-- following order:
--
--   op  KL  expr function

   Compiling FriCAS source code from file 
      /var/lib/zope2.10/instance/axiom-wiki/var/LatexWiki/2085712962103641450-25px001.spad
      using old system compiler.
   PARTSET abbreviates category PartitionedSet 
------------------------------------------------------------------------
   initializing NRLIB PARTSET for PartitionedSet 
   compiling into NRLIB PARTSET 

;;;     ***       |PartitionedSet| REDEFINED
Time: 0 SEC.

   finalizing NRLIB PARTSET 
   Processing PartitionedSet for Browser database:
--------constructor---------
--------(position ((NonNegativeInteger) %))---------
--------(setPosition ((Void) % (NonNegativeInteger)))---------
; compiling file "/var/aw/var/LatexWiki/PARTSET.NRLIB/PARTSET.lsp" (written 04 APR 2022 08:04:49 PM):

; /var/aw/var/LatexWiki/PARTSET.NRLIB/PARTSET.fasl written
; compilation finished in 0:00:00.004
------------------------------------------------------------------------
   PartitionedSet is now explicitly exposed in frame initial 
   PartitionedSet will be automatically loaded when needed from 
      /var/aw/var/LatexWiki/PARTSET.NRLIB/PARTSET

   KERNEL abbreviates domain Kernel 
------------------------------------------------------------------------
   initializing NRLIB KERNEL for Kernel 
   compiling into NRLIB KERNEL 
   compiling exported operator : $ -> BasicOperator
      KERNEL;operator;$Bo;1 is replaced by SPAD-KERNEL-OP 
Time: 0.01 SEC.

   compiling exported argument : $ -> List S
      KERNEL;argument;$L;2 is replaced by SPAD-KERNEL-ARG 
Time: 0 SEC.

   compiling exported height : $ -> NonNegativeInteger
      KERNEL;height;$Nni;3 is replaced by SPAD-KERNEL-NEST 
Time: 0 SEC.

   compiling exported position : $ -> NonNegativeInteger
      KERNEL;position;$Nni;4 is replaced by SPAD-KERNEL-POSIT 
Time: 0 SEC.

   compiling exported setPosition : ($,NonNegativeInteger) -> Void
      KERNEL;setPosition;$NniV;5 is replaced by SET-SPAD-KERNEL-POSIT 
Time: 0 SEC.

   compiling local mkKer : (BasicOperator,List S,NonNegativeInteger) -> $
      KERNEL;mkKer is replaced by makeSpadKernel 
Time: 0 SEC.

   importing XHashTable(List NonNegativeInteger,Boolean)
   compiling exported is? : ($,Symbol) -> Boolean
Time: 0.01 SEC.

   compiling exported is? : ($,BasicOperator) -> Boolean
Time: 0 SEC.

   compiling exported name : $ -> Symbol
Time: 0 SEC.

   compiling exported kernel : Symbol -> $
****** comp fails at level 2 with expression: ******
error in function kernel 

(|kernel| (|assert| (|operator| |s| 0) SYMBOL) | << | (|nil|) | >> | 1)
****** level 2  ******
$x:= (nil)
$m:= $EmptyMode
$f:=
((((|s| # #) (|preds| #) (|bin| # #) (* #) ...)
  ((|mkKer| #) (~= #) (= #) (|coerce| #) ...)))

   >> Apparent user error:
   cannot compile (nil)

k1:=kernel(operator 'test,[x1,x2],2)$Kernel(EXPR INT)

(1)

position k1

(2)

k2:=kernel(operator 'test,[x1,x2],2)$Kernel(EXPR INT)

(3)

position k2

(4)

(k1=k2)$Kernel(EXPR INT)

(5)

position k1

(6)

position k2

(7)

--
sqrt(a)*sqrt(b)

(8)

k1:=kernels %

(9)

map(position,k1)

(10)

sqrt(a)*sqrt(c)

(11)

k2:=kernels %

(12)

map(position,k2)

(13)

setIntersection(k1,k2)

(14)

map(position,k1)

(15)

map(position,k2)

(16)