incr_set prlevel 1
if #0>=2 START
incr_set prlevel -1
;;; Usage:
;;; 	<sagbi_step gens newgens [d]
;;;
;;; Given an ideal gens representing a system of
;;; (homogeneous) generators for a subring
;;; of the polynomial ring, newgens is set to
;;; the list of polynomials
;;; that are added to the partial sagbi basis
;;; represented by gens in one step of the 
;;; Robbiano-Sweedler algorithm.
;;;     If the optional bound d is present, it
;;; is used as a degree bound for the main computation,
;;; which is an std near the beginning that computes
;;; the relations on the initial form of gens.
;;;      Thus the computation will succeed iff
;;; d is >= the maximum degree of a new sagbi 
;;; basis element that would be produced.
;;; 
;;;
incr_set prlevel 1
jump END
;;; Parameters:
;;;
;;; Output values:
;;;
;;; In the examples I have done, by far the hardest
;;; step is the first std computation.  Thus computing
;;; a good value for d at the beginning would 
;;; potentially speed up the process very 
;;; much.
;;;
;;;
; created June 14, 1992 DE modified 8/3/94 John P. Dalbec
START:
setring #1
; It is potentially dangerous to sum two rings without knowing that they don't
; have variables in common.  We copy the current ring to a new ring @r with
; variables of the form B[number].  JPD 8/3/94
; This also works around the weight vector bug in ring_sum.  JPD 8/3/94
<copyring B @r ; new ring with known variables (and no weight vectors) JPD
copy #1 @i
compress @i @i 
;if there were a zero we'd have
;trouble with "in"
<getvars @origvars
ncols @origvars @noldvars
in @i @j
ev @r @j @j ; map @j to new ring for ring_sum - JPD
;ncols #1 @nvars (#1->@i JPD)
ncols @i @nvars
;col_degs #1 @degs (#1->@i JPD)
col_degs @i @degs
ring @s
;
@nvars
A[1]-A[@nvars]
@degs
;
;
;ring_sum #1 @s @t (#1->@r JPD)
ring_sum @r @s @t ; use new ring in ring_sum - JPD
fetch @j @js
fetch @s @svars
;fetch @origvars @origvars (@origvars->@r JPD)
fetch @r @origvars ; use variables from new ring - JPD
subtract @svars @js @diffs

;the following seems to be the hardest step
;in the process
shout echo computing relations on initial forms
if #0=3 degbnd
shout std @diffs @diffs
jump donestd
degbnd:
set autocalc 1
set autodegree #3
shout std @diffs @diffs 
set autocalc -1
donestd:

elim @diffs @relns
setring #1
<zeromat 1 @noldvars @map
concat @map #1
ev @map @relns @errorterm ; @errorterm is defined over the original ring

; Subduce the elements of @errorterm.
;     In each pass through the loop 
; we will decide which monomials of @e are already
; in the ring generated by @j, and subtract
; the corresponding monomials in the elements
; of #1 from the corresponding elements of 
; @errorterm.  We are done if no elements of
; @e are in the ring generated by @j.  The process
; terminates because of homogeneity.

subduction:
compress @errorterm @errorterm

shout echo subducing new generators of degrees
shout col_degs @errorterm

in @errorterm @e
ev @r @e @e ; map @e to new ring before fetching to ring sum - JPD
setring @t
fetch @e @E

reduce @diffs @E @E

;how many nonzero terms?
compress @E @temp
ncols @temp @test

;are any of the elements of @E expressions in 
;the variables A.. alone?  Any such will become
;0 on contraction with @origvars
contract @origvars @E @E1
mult @origvars @E1 @E1
compress @E1 @temp
ncols @temp @test1
if @test=@test1 done 
; in this case nothing was achieved.

;now replace in @E any elements involving the 
;orig vars with 0.  These correspond to the 
;nonzero columns of @E1
;(note that such an element might be
;a difference (in orig vars)-(in new vars)
;so some care is necessary

<select @E @E1 @temp @E
ev @map @E @rederror ; @rederror is defined over the original ring
subtract @errorterm @rederror @errorterm
jump subduction
done:

; Next see which elements of @errorterm actually
; add generators to the initial algebra

ncols @j @num_old
compress @errorterm @errorterm ; because of bug in "in"
ncols @errorterm @num_new
if @num_new=0 DONE
shout echo starting to minimize generators of degrees
shout col_degs @errorterm

in @errorterm @j1
ev @r @j1 @j1 ; map @j1 to new ring (@j already defined over new ring) JPD
concat @j @j1
ncols @j @nvars

col_degs @j @degs
ring @s
;
@nvars
A[1]-A[@nvars]
@degs
;
;
;ring_sum #1 @s @t (#1->@r JPD)
ring_sum @r @s @t ; use new ring in ring_sum - JPD
fetch @j @j
fetch @s @svars
subtract @svars @j @diffs

;To eliminate the extra generators that occur
;linearly in a relation, we only need to compute
;the relations up to the max degree of a 
;generator!
max @degs @max
set autocalc 1
set autodegree @max
shout std @diffs @diffs
set autocalc -1

elim @diffs @relns1
setring @s
fetch @relns1 @relns1

;find which variables occur linearly
;(if there's a difference of two, we'll
;want to eliminate just 1, etc)
contract @s @relns1 @trash
<zeromat 1 @nvars @zeros
ev @zeros @trash @trash
mult @s @trash @trash
;now trash contains just the linear terms of 
;the relns

;and throw in the variables corresponding
;to old generators (the first @num_old variables)
submat @s @first
;
1..@num_old
concat @trash @first
std @trash @trash

;Make a minimized list of the variables that span, mod
;the trash
reduce @trash @s @min
set autocalc 1
set autodegree @max
std @min @min
set autocalc -1

concat @i @errorterm


DONE:
ev @i @min #2 ; #2 is defined over original ring
compress #2 #2
if @num_new=0 no_new
shout echo found new minimal generators of degrees
shout col_degs #2
shout type #2
jump END
no_new:
shout echo no new sagbi basis elements found

;(clean up code)
END:
incr_set prlevel -1

$;;;;;;;; EXAMPLE SECTION ;;;;;;;;;;;;;;;;;;;;;;;;;
reset
;symmetric functions of deg 2
<ring 2 a-z r
<ideal sym a+b a2+b2
<sagbi_step sym newsym

;and deg 3
<ring 3 a-z r
<ideal sym a+b+c a2+b2+c2 a3+b3+c3

<sagbi_step sym newsym

copy sym sym1
concat sym1 newsym
type sym1
<sagbi_step sym1 newsym1


; 2x2 minors of a generic 3x3 mat
<ring 9 x[1,1]-x[3,3] r
<generic_mat x[1,1] 3 3 m
type m
; x[1,1] x[1,2] x[1,3] 
; x[2,1] x[2,2] x[2,3] 
; x[3,1] x[3,2] x[3,3] 
wedge m 2 m2
flatten m2 m2
<sagbi_step m2 n
; x[1,3]x[2,1]x[2,3]x[3,1]-x[1,2]x[2,2]x[2,3]x[3,1]-x[1,3]x[1,4]x[2,4]x[3,1] \
;     +x[1,1]x[2,2]x[2,4]x[3,1]+x[1,2]x[1,4]x[3,1]2-x[1,1]x[2,1]x[3,1]2 

; x[1,1]x[1,3]x[2,1]x[2,3]-x[1,1]x[1,2]x[2,2]x[2,3]-x[1,1]x[1,3]x[1,4]x[2,4] \
;     +x[1,1]2x[2,2]x[2,4]+x[1,1]x[1,2]x[1,4]x[3,1]-x[1,1]2x[2,1]x[3,1] 

betti n
; total:      1     2 
; --------------------
;     0:      1     - 
;     1:      -     - 
;     2:      -     - 
;     3:      -     2 
copy m2 I
concat I n
<sagbi_step I i


; 2x2 minors of a generic 3x4 mat
<ring 12 x[1,1]-x[3,4] r
<generic_mat x[1,1] 3 4 m
type m
wedge m 2 m2
flatten m2 m2
;<sagbi_step m2 n
<sagbi_step m2 n 4  ;this is the optimal bound
betti n
; total:      1    10 
; --------------------
;     0:      1     - 
;     1:      -     - 
;     2:      -     - 
;     3:      -    10 
copy m2 I
concat I n
<sagbi_step I i
betti i
;nothing new - I is a sagbi basis.
betti I
; total:      1    28 
; --------------------
;     0:      1     - 
;     1:      -    18 
;     2:      -     - 
;     3:      -    10 


; now the example Bernd and I computed.  The
;"symmetric" quadratic artin ideal in 2x3 vars
<ring 6 a-z r
<ideal i a  b c
power i 2 i
<ideal i2 d e f
power i2 2 i2
<ideal i3 a+d b+e c+f
power i3 2 i3
concat i i2 i3
std i i
type i
betti i
<sagbi_step i j

copy i I
concat I j
<sagbi_step I J
;no new generators found! The final list:
betti I
; --------------------
;     0:      1     - 
;     1:      -    18 
;     2:      -     - 
;     3:      -    10 
type I
; a2 ab ac b2 bc c2 d2 de df e2 ef f2 ad 
; bd+ae cd+af be ce+bf cf 
; bf3 af3 -aef2 
; ae2f ae3 -b3f -ab2f -2a2bf -a3f -a3e 



