incr-set prlevel 1
if #0>=2 START
incr-set prlevel -1
;;; Usage:
;;; 	<unmixed_radical I I1 [verbose]
;;;
;;; Sets I1 = the intersection of the primes of 
;;; minimal height containing an ideal I
;;; in a polynomial ring, by the 
;;; iterated jacobian minor method.
;;;
;;; Shouts progress reports -the size of jacobian
;;; minors being used followed by betti of the
;;; resulting quotient ideal at each stage -- if
;;; a third argument is present.
;;;
;;; Unless one knows in advance that I 
;;; is unmixed, one must do
;;; <remove_low_dim I I
;;; (which runs relatively fast)
;;; before using this script.
;
incr-set prlevel 1
jump END
;;; Parameters:
;;;         I an ideal
;;;          [verbose] anything or nothing
;;; Output values:
;;;          I1 an ideal, reduced and equal to the
;;;          radical of I along the components of
;;;          I of maximal dimension.
;;;     Method:
;;; Repeat:
;;; Find the smallest order minors
;;; of the jacobian matrix which are in a prime of I of 
;;; minimal codimension, 
;;; and take the ideal quotient with respect to
;;; them
;;;
;;; as long as the size minor in question is
;;; <= the codimension of I
;;;
;;; Caveats: This method probably doesn't work if
;;; we start in a factor ring.  Does it work if
;;; the variables have different weights?
;;;
;;; The script is also limited by Macaulay's current
;;; limitation to 10x10 or smaller minors.  Thus
;;; one cannot even try to compute the radical of 
;;; an ideal of codimension >10, though this
;;; probably wouldn't be realistic anyway.
;;;
; created 11/10/89
START:
;Get a means of returning to the original ring:
setring #1
<getvars @oldvars
nvars #1 @nvars

;move to a ring with just one block
;of variables:
<copyring a @r 
setring @r
ev @r #1 @I

;compute the codim of I
std @I @I
<codim @I @codimI
;Handle the case that I is the unit ideal:
;(there will be some "variable .. doesn't exist" messages.)
if @codimI>@nvars end1

;initialize the loop
int @size 0

inc_size:
int @size @size+1
if @size>@codimI end1

same_size:
;The basic loop:
jacob @I @J

;The following line might run faster mod I,
;but Macaulay's algorithm for determinants doesn't work
;except over a domain (11/25/89)
wedge @J @size @J
flatten @J @J
;test to see whether @J is in a
;prime of minimal codim over @I
qring @I @qr
fetch @J @J
std @J @J

;compute the codim of @J+@I. Since we are in @qr,
;this is just the codim of @J.
;Note that these give the codim
;IN @r, not in @qr
;Use the workaround for codim if codim I = nvars
if @codimI<@nvars nofix
<codim @J @test
jump donefix
nofix:
codim @J @test
donefix:

;print progress report if the third argument is present:
if #0<3 continue
shout echo current size of Jacobian minors and the minors:
shout type @size
shout  betti @J
shout echo
continue:

;If codim @I+@J > codim @I, increment size and repeat:
if @test>@codimI inc_size

;else compute the quotient.  Note that we
;automatically have a minimal set of gens of J mod I.
setring @r
fetch @J @J

quotient @I @J @I 
;this gives @I with a std basis


;print progress report if the third argument is present:
if #0<3 continue1
shout echo improved ideal:
shout betti @I
shout echo 
continue1:

jump same_size

end1:

;Move the answer back to the original ring:
ev @oldvars @I #2

kill @r'zero @r @qr'zero @qr @codimI @I @J @size 
kill @oldvars @test @nvars   

END:
incr-set prlevel -1
$;;;;;;;; EXAMPLE SECTION ;;;;;;;;;;;;;;;;;;;;;;;;;
reset
<ring 3 a-z r
<ideal i a4 
<unmixed_radical i j ver
type j
;a
listvars
; ;;;;;;;;;;;;;;;
<ring 4 a-z r
<ideal ia a b 
power ia 3 ia3
<ideal ic c d 
power ic 2 ic2
intersect ia3 ic2 i
betti i
<unmixed_radical i j ver
<unmixed_radical i j 
type j
; ad bd ac bc 
jacob j jj
wedge jj 2 jj
flatten jj jj
std jj jj
betti jj
;There are 10 quadrics here, but only 4 mod j;
;so working mod j does one some good in this case.
; ;;;;;;;;;;;;;;;;;;;;;
<ring 3 a-z r
power r 3 r3
<unmixed_radical r3 j ver
type j
;a b c

; ;;;;;;;;;;;;;;;;;

<ring 5 a-z r
;ideal i
;3
;a5+b5+c5+d5+e5-5abcde
;ea3b+ab3c+bc3d+cd3e+de3a
;e2ab2+a2bc2+b2cd2+c2de2+d2ea2
;<remove_low_dim i i1
;betti i1
;set prcomment -1
;putmat i1
;set prcomment 1
mat i1
1
8
a2bc2+b2cd2+a2d2e+ab2e2+c2de2
ab3c+bc3d+a3be+cd3e+ade3
a5+b5+c5+d5-5abcde+e5
ab2c4-b5cd-a2b3de+2abc2d2e+ad4e2-a2bce3-cde5
abc5-b4c2d-2a2b2cde+ac3d2e-a4de2+bcd2e3+abe5
a4b2c-abc2d3-ab5e-b3c2de-ad5e+2a2bcde2+cd2e4
a3b2cd-bc2d4+ab2c3e-b5de-d6e+3abcd2e2-a2be4-de6
b6c+bc6+a2b4e-3ab2c2de+c4d2e-a3cde2-abd3e2+bce5
;set prlevel 0
;set timer 1
<unmixed_radical i1 j verbose
type j
betti j
res j j
betti j

; ;;;;;;;;;;;;;;;;;;;;;;;;;
;Recovery of a scroll from a k3 carpet:

;First make a k3carpet in a+b+2 variables
;for this to work the following integers must
;be >=2

reset

int a 2
int b 3
<ring a+1 x[0]-x[a] r1
<ring b+1 y[0]-y[b] r2
ring-sum r1 r2 r
cat x[0] A
0 1
0..a-1
cat y[0] B
0 1
0..b-1
type A
type B

<k3carpet A B i

;set autocalc 1
;set autodegree 2
;res i ii 
;betti ii
;should - and does - show the last linear term
;in the bth place.  Note that the codim is a+b-1
;and the degree is 2(a+b) = 2(g-1).

type i

set prlevel -1

set timer 1
<unmixed_radical i j ver

;About 3 minutes for the case a=2,b=3,
;down from 25 for the old version.
;This makes one
;wish that there were a good way of taking a single "random" element
;of B to do this.  Maybe we should experiment with a "random element"
;or a "random minor" script.
;The case a=3 b=3 ran for about 4 hours before 
;running out of memory in about 7 MB.

res j j
betti j
pring j
