incr-set prlevel 1
if #0>=3 START
incr-set prlevel -1
;;; Usage:
;;; 	<push_forward1 f M N [maxdegree]
;;;
;;; Given a map f from the current ring R to a ring S and a matrix 
;;; presenting a module M over S, the script forms a presentation 
;;; matrix for the R-submodule of M generated generators given 
;;; for M as an S-module.  
;;;     It is assumed that the first ncols f variables in R 
;;; have degrees proportional to the column degrees of f.
;;;     If the optional parameter maxdegree is present, then the answer
;;; is computed only up to degree maxdegree, computed in terms of the
;;; degrees of elements of f.  (For example if f consists of cubics, 
;;; then to find a quadratic relation maxdegree must be >= 6.) 
incr-set prlevel 1
jump END
;;; Parameters:
;;;     f = 1xn matrix
;;;     M = matrix over the same base ring as f
;;;
;;; Output values:
;;;	   N = matrix over the current ring, whose rows correspond to those
;;;        of M.
;;;
;;; This script performs a very basic set of operations.  It is used 
;;; by several others (see them for descriptions):
;;;
;;; 1. <subring             ;forms a subring given its generators
;;;
;;; 2. <push_forward        ;writes a module as a module over another ring
;;;
;;; 3. <diagonal_submodule  ;Finds the submodule generated by n,n forms in a 
;;; 						;bigraded module
;;;
;;; 4. <from_bigraded       ;finds the singly graded module associated to a
;;;	                        ;bigraded module by the Segre map.
;;;
;;; It can be used directly to compute the "pushforward" of  
;;; M as long as the given S-generators of M
;;; generate it over the ring R.
;;;
;;;
;;; Caveats: 
;;; 1. If R and S do not have the same characteristic there may
;;; be trouble!
;;;
;;; 2. If R is a quotient ring and the relations satisfied by R are
;;; not satisfied by the elements of f (so that f is not really a map)
;;; then the effect is to impose the additional relations satisfied by the
;;; variables of R; that is, the effect is as if we first factored out these
;;; relations from S and M.
;;;
;;; 3. The script does its main work over a new ring SR = S \tensor R
;;; which has two blocks of variables, one from S and one from R.  If
;;; the number of variables in one of these blocks is large and/or if the
;;; degrees of the entries of f are large, there could be problems with
;;; the "degree bound exceeded".  In that case one should use the idea of 
;;; the script but do the work "by hand", making many blocks (and eliminating
;;; as many as necessary.)
;;;
;;; 4. The script returns a set of relations that usually isn't
;;; minimal; of course one can then do an std or nres or... to
;;; find a minimal set of relations (the generators returned
;;; are minimal generators.)
;;; 
;;; 5.  If the entries of f are independant linear forms, 
;;; then the script uses
;;; a different method, not introducing any new variables, but 
;;; rearranging things so as to be able to eliminate all but the
;;; first ncols f variables.
;;;
;;; 6.  If maxdegree is specified, the current settings for autodegree
;;; and autocalc are overwritten.
;;;
;;; 7.  However,in the "easy linear" case, where the entries of f are a basis
;;; for the linear forms in the base ring S of M, only a variable change 
;;; is needed, and maxdegree does nothing.

; last modified November 14, 1989 DE
;linear algorithm corrected 5/18/90 DE
START:
<getvars @curring
ncols @curring @ncurring
;Bail out if f is unsuitable (not 1xn with n>=1)
nrows #1 @nrowsf
ncols #1 @ncolsf
if @nrowsf!=1 BADF
if @ncolsf=0 BADF
if @ncolsf>@ncurring BADF

;Test to see whether f consists of 
;independant linear forms, and
;the variables of the base ring of f
;are all degree 1, and
;branch if so:
;Create all the variables that will be used in 
;the tests so that they can be killed uniformly:
int @mindeg 0
int @vardeg 0
int @ncolsf' 0

copy #1 @f

;Check whether all the entries of f are degree 1:
min @f @rowdegf
dshift @f -@rowdegf
transpose @f @f'
min @f' @mindeg
max @f' @maxdeg
if @mindeg!=-1 nonlinear
if @maxdeg!=-1 nonlinear

;check whether the variables are degree 1:
setring @f
<getvars @oldvars
transpose @oldvars @oldvars'
min @oldvars' @vardeg ;This is minus the max degree
if @vardeg!=-1 nonlinear

;Check that the entries of f
;are independant.  This is necessary because
;the script x_to_last chokes on linearly dependant
;rows.
std @f @f'
ncols @f @ncolsf
ncols @f' @ncolsf'
if @ncolsf!=@ncolsf' nonlinear
jump linear

nonlinear:
; Make a map to the current ring using the same number of variables as the
;number of columns in f, followed by as many zeros as there are variables
;in S.  This will serve in the end to map back from the tensor product
;S \tensor R to R:
nvars #2 @nS 
setring @curring
submat @curring @curring
	1
	1..@ncolsf
<zeromat 1 @nS @to_curring
concat @to_curring @curring

;Make a ring @Rthe degrees of whose variables match the entries of f.
;Even if R is a quotient ring, we leave @R as a polynomial ring;
;the effect of the last evaluation will be to reimpose the relations of R.
;First make sure that the row degree of f is 0.Use dshift rather than
;setdegs to avoid disturbing the case where f has some 0's in it.:
copy #1 @f
min @f @rowdegf
dshift @f -@rowdegf
col-degs @f @degsf
char @f @charf
ring @R
	@charf
	@ncolsf
	A[1]-A[@ncolsf]
	@degsf
	;
;Make a copy of S to ensure that there is no conflict of variables:
setring #1
<copyring B @S
col-degs @S @degsS

;Make the tensor product ring.
;Note that the block of variables from S comes first, so that we
;can eliminate:
ring-sum @S @R @SR

;Create the ideals of variables from R and from S:
;The setdegs in the following are necessary because of a
;bug in "fetch"
fetch @S @Svars
setdegs @Svars
;
@degsS
fetch @R @Rvars
setdegs @Rvars
;
@degsf
;Use Svars as a map to move f and M over to SR
ev @Svars @f @f
ev @Svars #2 @M

;Make the R-variables act on M via f:
subtract @f @Rvars @diffs

;In case the given map, #1, had some zeros in it, @f will be inhomogeneous
;at this point, so diffs will be too. Fix this:
setdegs @diffs
0
; The default should reset the degrees correctly.


tensor @M @diffs @M

;Eliminate the S variables from M to get the result N:

if #0=3 set_auto
set autocalc 1
set autodegree #4
set_auto:

std @M @M

if #0=3 reset_auto
set autocalc -1
reset_auto:

elim @M #3

;Map back to the current ring:  
ev @to_curring #3 #3

;Cleanup of nonlinear case:
kill @nrowsf @ncolsf @curring @ncurring @nS @to_curring 
kill @R'zero @R @S'zero @S @SR'zero @SR @f' @maxdeg
kill @Rvars @Svars @f @diffs @M @degsf @charf @rowdegf
kill @vardeg @mindeg @ncolsf'
jump END


;Now the code for treating the linear case:
linear:
;Do this over a ring with just one block,
;and with the elimination order:
nvars #2 @nvarsS

;if there are no variables actually eliminated, 
;then all we have to do is a change of vars. Else we're in
;the main case.
<getvars @varsS
if @ncolsf-@nvarsS main_case ;jump if not equal
lift-std @f @f
lift @f @varsS @change
setring @curring
fetch @change @change
mult @curring @change @change
ev @change #2 #3

;If the base ring R of M is a quotient ring, we must
;put this data in by tensoring M with the defining ideal, 

present-ring #2 @defideal
ncols @defideal @test

if @test=0 not_a_quotient0
;tensor with M.
ev @change @defideal @defideal
tensor @defideal #3 #3
not_a_quotient0:

;Cleanup of Easy case
kill @curring @ncurring @nrowsf @rowdegf @mindeg @maxdeg @oldvars 
kill @oldvars' @vardeg @f' @ncolsf @ncolsf' @nvarsS @varsS @f @change 
kill @test @defideal 
jump END


main_case:
char #2 @charS
ring @R
	@charS
	@nvarsS
	A[1]-A[@nvarsS]
	;
	w
	A[@nvarsS-@ncolsf]
	
;Make the last @ncolsf variables of the
;new ring act on @M as the entries of @f
;acted on #2.
<x_to_last @f @change @dummy ;we never go back
ev @change #2 @M

;If the base ring S of M is a quotient ring, we must
;put this data in by tensoring M with the defining ideal, 
;expressed as an ideal of @R.  
; ;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Note that we cannot simply
;make @R a quotient ring, as the relations may not
;show up when we do the elim.
;Example:  if S = M = k[a]/a2, R = k[a], then M is presented
;by the empty matrix, and std, elim, etc will produce the empty
;matrix as an answer.
; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
present-ring #2 @defideal
ncols @defideal @test

if @test=0 not_a_quotient
;move defideal to an ideal of @R
;and tensor with M.
ev @change @defideal @defideal
tensor @defideal @M @M
not_a_quotient:

;Now do the elimination, up to maxdegree if specified
if #0=3 set_auto1
set autocalc 1
set autodegree #4
set_auto1:

std @M @M

if #0=3 reset_auto1
set autocalc -1
reset_auto1:

elim @M @M

;Map to the original current ring.  
;The last @ncolsf variables of @S must be
;sent to the first @ncolsf variables of that ring,
;which are in @curring, the rest sent to 0:
setring @curring

ncols @R @nvarsR
setring @curring
<zeromat 1 @nvarsR-@ncolsf @tocurring
submat @curring @firstvars
1
1..@ncolsf
concat @tocurring @firstvars
ev @tocurring @M #3

;cleanup from linear case
kill @f @f' @maxdeg @M
kill @curring @ncurring @nrowsf @rowdegf @oldvars 
kill @oldvars' @ncolsf @nvarsS @charS @R'zero 
kill @R @defideal @test @dummy @change @nvarsR 
kill @tocurring @firstvars 
kill @vardeg @mindeg @ncolsf' @varsS

jump END

BADF:
;Handle cases of unsuitable f
shout echo push_forward1 was called with a matrix f with
shout type @nrowsf
shout echo rows and 
shout type @ncolsf
shout echo columns

END:
incr-set prlevel -1

$;;;;;;;; EXAMPLE SECTION ;;;;;;;;;;;;;;;;;;;;;;;;;
;Sheaves on P1 x P1 (for an automated version of this,
;see the examples for the script from_bihomogeneous.)
reset
ring r
;
4
x[1]-x[2]
y[1]-y[2];
;
;

cat x[1] xvars
0
0..1
cat y[1] yvars
0
0..1

transpose yvars yvars'
mult yvars' xvars zvars
flatten zvars f
type f

;The bihomogeneous ideal of a point:
ideal i
2
x[1]
y[1]

;A bihomogeneous ideal of the empty set:
ideal j
2
x[1]
x[2]

;The twisted cubic:
ideal k
1
x[1]y[1]2+x[2]y[2]2

;Since 1 in r is of degree 0,0, we can take M0 = r/i
;and no modulo is necessary.

<ring 4 z[1,1]-z[2,2] s

<push_forward1
<push_forward1 f i N
nres N N
betti N ;the ideal of a point
; total:      1     3     3     1 
; --------------------------------
;     0:      1     3     3     1 

<push_forward1 f j N
nres N N
betti N ;the ideal of the empty set
; total:      1     4     6     4     1 
; --------------------------------------
;     0:      1     4     6     4     1 

<push_forward1 f k N 4
nres N N ;the ideal of the twisted cubic
betti N
; total:      1     3     2 
; --------------------------
;     0:      1     -     - 
;     1:      -     3     2 
degree N.1
; codimension : 2
; degree      : 3

; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Yau's example projected to P2xP3
reset
;The bihomogeneous coordinate ring of P3 x P3:
ring r

8
a[0]-a[3]
b[0]-b[3]

;The ideal of the product of two cubic surfaces, cut by a hyperplane:
ideal i
3
a[0]3+a[1]3+a[2]3+a[3]3
b[0]3+b[1]3+b[2]3+b[3]3
a[0]b[0]+a[1]b[1]+a[2]b[2]+a[3]b[3]


std i ii
degree ii
; codimension : 3
; degree      : 18


ring s
;
7
a[0]-a[2]
b[0]-b[3]
1
;
pring s

;Now choose 2 linear forms in the a's.
;We want the projection
;to be birational.  Think of it as P3xP3 -> P2xP3.  Note that we need to
;project from a point p in P3 such that p x P3 doesn't meet Yau's variety X.
;Luckily the projection of X to P3 is contained in the cubic hypersurface.
;Thus simply taking the first 3 vars should be ok:

imap f s r
;
setring s
<push_forward1 f i n

std n n
degree n
; codimension : 2
; degree      : 18
numinfo n
type n.1

;The projection to P3 is still the cubic, so any pair of b variables will
;give a well defined map to P2xP2.  However, 
;we get something which is not birational

ring s1
;
6
a[0]-a[2]
b[0]-b[2]
1
;
pring s1

;Now choose 3 linear forms in the b's

imap f1 s1 s
b[0] b[0]+5b[3]
;
set prlevel -5
setring s1
<push_forward1 f1 n n1

std n1 n1
degree n1
;The result is not birational -- it has the wrong degree.

; ;;;;;;;;;;;;;;;;;;;;;;;;;;
;Test the safety net:
<ring 3 a-c r
<zeromat 1 0 f   ;no cols
type f
ncols f nc
type nc
nrows f nr
type nr
set prlevel 0
<push_forward1 f r test

; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;An example of pushing forward from a factor ring:
;The middle monomial ribbon of genus 5:
;Define s=k[s,t,y]/y2
reset
<ring 3 sty s
<ideal i y2
std i i
qring i s
<zeromat 1 0 pres_of_s ;A presentation of the free module of rank 1.

;Define the ideal tot of generators of the subring
;defining the middle monomial ribbon:
<ideal tot t4 t3s t2s2 ts3-t3y s4-2st2y
type tot

<ring 5 a-z s
<push_forward1 tot pres_of_s rib 8  ;7 is not enough!
type rib
res rib rib
betti rib


; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Some linear projections:
reset
<ring 3 a-z P2
<ring 4 a-z P3
<ideal curve a5+b5+c5+d5 ab+ac+bc
<ideal f a+d b+2d c

setring P2
set prlevel -10
set timer 1
<push_forward1 f curve planecurve 10 ;the 10 helps a little here
;4.25 secs (6.28 without the linear code)
type planecurve
listvars

;A hard example:
<ring 5 a-z r
ideal i
3
a5+b5+c5+d5+e5-5abcde
ea3b+ab3c+bc3d+cd3e+de3a
e2ab2+a2bc2+b2cd2+c2de2+d2ea2
std i i
degree i
; codimension : 2
; degree      : 15

;eliminate one variable to make it principal
<ideal f a+b 2a+c 3a+d 4a+e

<ring 4 a-z r1
set timer 1
set prlevel -1
<push_forward1 f i j
;Without the linear code:
;time 160 minutes , 17**K of space, to degree 16
;The resulting 15th degree form took 2 seconds to 
;print!

;With the linear code:
;78 minutes, about the same space.
type j


;The simplest possible projection of the same ideal:
reset
<ring 5 a-z r

ideal i
3
a5+b5+c5+d5+e5-5abcde
ea3b+ab3c+bc3d+cd3e+de3a
e2ab2+a2bc2+b2cd2+c2de2+d2ea2

<ideal f b c d e

<ring 4 a-z r1
set timer 1
set prlevel -1
<push_forward1 f i j 15 
;half as long with the 15 as without.
;half as long with with the linear code as without.
betti j

type j
std j j


; ;;;;;
;a test of the linear case (was a bug till 5/18/90)
reset
<ring 2 a-z T
<ideal vertex b
<ideal map b

<ring 1 x[1] T1
<push_forward1 map vertex A1
type A1 
; x[1] 

; ;;;;;;;;;

;Another sort of linear example:
;Was a bug in the linear code till 11/10/90
;First test the routine that really makes a projection,
;the "main case" of linear projection
reset
<ring 2 uv S1  
<ideal J u4 v4
forcestd J J
qring J S
<zeromat 1 0 pres_of_S

<ideal map u+v 

<ring 1 t R

;set prlevel -1
<push_forward1 map pres_of_S X 7

type X 
;t7
listvars
; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Next test the "easy case" of linear projection
reset
<ring 2 uv S1  
<ideal J u4 v3
forcestd J J
qring J S
<zeromat 1 0 pres_of_S

<ideal map v u 

<ring 2 st R

;set prlevel -1
<push_forward1 map pres_of_S X 1 
;the maxdegree option has no effect 
;in this case.

type X 
;
listvars
