LiE/0000744000175000017500000000000010305606502010450 5ustar hakanhakanLiE/INFO.00000664000175000017500000003320306224145647011306 0ustar hakanhakan@history() The development of LiE was initiated in Jan 1988 by the computer algebra group at CWI, Amsterdam. Members of this group, and their contributions, have been the following: Arjeh M. COHEN (the idea, many mathematical functions, the first manual, project leader), Ron SOMMELING (first version, mathematical programs, trouble shooting), Bert LISSER (the kernel and the interpreter), Bart de SMIT (mathematical programs), Bert RUITENBURG (tests, texts, examples), Marc van LEEUWEN (math programs, rewriting and new functions for version 2.0, manual for version 2.0, adaptation and source documentation for version 2.1). @version() Version 2.1 Available publicly from URL http://www.cwi.nl/~maavl/LiE Runs on UNIX platforms and with some limitations on all ANSI C platforms. Tested ports exist to SGI, SUN and Atari ST @size(vec)array size(v). Returns the size of a vector. @degree(pol)polynomials degree(p). Returns the degree of a polynomial. degree(p) = max { degree(p[i]) | 1 <= i <= length(p) } degree(p[i]) = sum (j=1..n_vars(p)) expon(p,i)[j] Example degree(X[1,2]+3X[3,4]) = 7 @expon(pol,int)polynomials expon(p,i). Returns the exponent vector of the i-th term of p. The terms are sorted first (sorting criterion can be set by `on ...'). Example expon(X[1,2]+3X[3,4],2) = [3,4] @coef(pol,int)polynomials coef(p,i). Returns the coefficient of the i-th term of p. The terms are sorted first (sorting criterion can be set by `on ...'). Example coef(X[1,2]+3X(3,4),2) = 3. @n_rows(mat)array n_rows(m). Returns the number of rows of m. @n_cols(mat)array n_cols(m). Returns the number of columns of m. @n_vars(pol)polynomials n_vars(p). Returns the number of indeterminates of p. @length(pol)polynomials length(p). Returns the number of non-zero terms of p. @*(vec,vec) v*w Returns standard inner product `sum (i=1..size(v)) v[i]*w[i]'. @*(mat,mat) Matrix multiplication. @*(int,pol) n*p Multiplies each term of p by n. @*(grp,grp) Direct product of groups. @*(mat,vec) Applies the matrix from the left to the (transposed) vector. @*(mat) Transposes the matrix. @.make(int,int) make(f,size) with f:int->int. Makes the vector [f(1),f(2),..,f(size)]. @.make(int,int,int) make(f,r,c) with f:int,int->int. Makes a r*c-matrix with i,j-entry f(i,j). @.make(int,vec) make(f,v) with f:int->int. Makes the vector [f(v[1]),f(v[2]),..,f(v[n])] where n=size(v). @.make(int,vec,vec) make(f,v,w) with f:int,int->int and vectors v,w. Makes the vector [f(v[1],w[1]),f(v[2],w[2]),..,f(v[n],w[n])] where n=size(v)=size(w). @.make(int,mat) make(f,m) with f:int->int and matrix m. Makes a r*c-matrix with i,j-entry f(m[i,j]), where r=n_rows(m), c=n_cols(m). @.make(int,mat,mat) make(f,m,n) with f:int,int->int and matrix m,n. Makes a r*c-matrix with i,j-entry f(m[i,j],n[i,j]), where r=n_rows(m), c=n_cols(m). @operators()lieshell arithmetic: + - * / % logical: && || comparison: == != <= >= < > @function()lieshell ( , , ... ; ... ) = | ( , , ... ; ... ) { } Examples f(int x,y;vec v)=x*v+y inc(int n) { print(n); n+1 } @type()lieshell 'int'= integer,'bin'=big integer, 'vec'= vector, 'mat'= matrix, 'grp' = group, 'tex'=text, 'vid'=void and 'pol' = polynomial. @integer()lieshell Entries of vectors, matrices and polynomial exponents are limited in magnitude to 2^31-1=2147483647. Other intgers are of unlimited magnitude. @vector()array ::= [ , ..., ] Example [1,-2,3,5] @matrix()array ::= [ , ..., ] Example [[1,2],[-3,5],[2,2345]] @group()group Simple Lie groups: A1, A2 ..., B2, B3, ..., C2, C3, C4, D3, D4, ..., E6, E7, E8, F4, G2. Semisimple groups: Concatenation of simple liegroups. Reductive groups: Semisiple group possily followed by central torus `Tn'. Example A3B6G2T5 @text()lieshell ::= "Any string, without carriage returns, enclosed in double quotes" "This is an example." @polynomial()polynomials An object of type `pol' is a polynomial. It is a sum of terms of the form `n X v', where n is an integer `coefficient' and v a vector `exponent'. Each term of the polynomial a vector of the same length as exponent, which length is called the number `n_vars' of indeterminates of the polynomial. A polynomial can be interpreted by choosing that many indeterminates, and using the first entry of each exponent as the power of the first indeterminate, etc. For example, the polynomial `X[2,0,7]+3X[0,2,0]' can be interpeted as 2 0 7 0 2 0 2 7 2 x y z + 3 * x y z ( = x z + 3 y) . @special()lieshell $ = last printed value , \ = command will be continued at next line , # = the characters typed in until the next '#' will be considered as comment. ? = request for information about the string typed after '?'. : = the string typed after ':' is command to the shell. '?' and ':' have to be the first characters of the command. @help() LiE has some features of a pocket calculator, but all numbers are integers. Formulas can be entered in the usual way like `(((2+3)*2-1)*2^(2-1)-2/3)'. Moreover, you can assign values to variables (a=2) and define functions (square(int i)=i*i). There exist objects of type integer, vector, matrix and group. The if-then-else-fi, while-do-od and for-do-od control structures are also available. Information about functions, variables and what more appears on the screen upon entering a question mark followed by the name of a query. Commands (like this ?feature) are executed when a is entered, unless LiE finds that you have an incomplete expression (e.g., an unclosed parenthesis), which can be forced by typing '\' as last character. Other useful help available: ?index, ?functions, learn index. @assignment()lieshell ::= = | loc = | += | = | += Examples my_var=4711, v=[2,4] loc count=0 count += 1 v[5]=3, m[3,-4]= 3*count m[3,4]+=7 @+(tex,tex) String concatenation @+(tex,bin) a+b appends to textual representation of b to string a @*(tex,int) a*b repeats string a b times. @if()lieshell ::= if then else fi | if then fi @for()lieshell ::= for = to do od | for = downto do od | for in do od | for row do od Examples for i=19 to 68 do print(i^3) od for j=47 downto 11 do print(j); f(j) od sum=0; v=[3,3,2,8]; for x in v do sum+=x od; sum for v row id(4) do print(v) od @commands()lieshell Special commands: quit, edit, read, write, monfil, on, off, maxobjects, maxnodes, listvars, listfuns, listops, help, ?, learn Type ? followed by command keyword for more information. @on()lieshell on shows parameter settings on runtime shows runtime after each executed command. on gc puts garbage collector on. on monitor maintains logfile. on prompt shows prompt. on bigints computation with integers of unlimited size.(default) on lprint lineair print. on + lex increasing lexicographic ordening (polynomials) on - lex decreasing lexicographic ordening on + degree increasing degree ordening on - degree decreasing degree ordening on + height increasing height ordening on - height decreasing height ordening These last 2 ordenings are connected to the default group (see setdefault). @off()lieshell clears the modes set by 'on'; see there for more details. @quit()lieshell exit @edit()lieshell 'edit' edits the most recently read or edited file (default: initfile), and executes the commands in that file after leaving the editor. 'edit "filename"' edits the file "filename". @null(int,int)array null(n,m) A zero matrix of n rows and m columns. @null(int)array null(n) A zero vector of size n. @all_one(int,int)array all_one(n,m) A matrix of n rows and m columns, with all entries 1. @all_one(int)array all_one(n) A vector of size n, with all entries. @poly_null(int,int)polynomials poly_null(n) A zero polynomial with n indeterminates. @poly_one(int,int)polynomials poly_one(n) A unit polynomial with n indeterminates. @id(int)array id(n) The n by n identity matrix @break()lieshell ::= break | break Exits the inner most do- or while-loop, returning the expression if present. @matvec(vec,int)array matvec(v,n) Returns a matrix with n rows and size(v)/n columns. The vector v is split into subvectors, which form the successive rows of m. @vecmat(mat)array vecmat(m) Returns a vector, which is the concatenation of the rows of m. @error()lieshell error(text) prints text and terminates the command being executed. @print()lieshell print(a) (any type a) prints a. @void()lieshell void(a) (any type a) Returns void (useful to match type of other expr.) @n_comp(grp)group n_comp(g) The number of simple components of g. @+(vec,int) v+n Extens v by the entry n. Example [1,2]+3=[1,2,3] @+(int,vec) n+v Prefix v by the entry n. Example: 1+[2,3]=[1,2,3] @+(mat,vec) m+v The matrix m with additional row v at the end. Example: [[1,2],[3,4]]+[5,6]=[[1,2],[3,4],[5,6]] @-(vec,int) v-i Remove the i-th entry v[i] from v. Example: [1,2,3]-2 = [1,3] @files()lieshell 1 In the Lie shell it is possible to execute an external text file with Lie shell commands. In order to execute the file `prog' one has to issue: read prog 2 It is possible to edit an external file in the Lie shell by entering the command edit prog The Lie shell chooses the editor defined in shell variable $EDITOR (only of UNIX). This variable has to be defined and exported by the shell from which Lie was invoked. After the editing the updated file `prog' will be executed. When a filename is omitted after the edit command, the most recently read or edited file will be taken. 3 It is possible to write the user defined functions on an external file `dest' by entering the command: write dest 4 If there is a file named `initfile' in the same directory as Lie, this file will first be read by entering Lie. The initfile must be a text file containing Lie shell commands. It is intended to contain your own data and functions. 5 It is possible to monitor a session. This will happen after issuing the command on monitor . All The Lie shell commands and their results will be written in the file named 'monfil'. It can be turned off by entering off monitor It is possible to specify an other file for monitor output by entering monfil otherfile. @write()lieshell It is possible to write the user defined functions on an external file `dest' by entering the command: write dest It is possible to write/append a value of a single variable or a definition of a single function on a file by entering ?name>dest (write) or ?name>>dest (append) @read()lieshell In the Lie shell it is possible to execute an external text file with Lie shell commands. In order to execute the file `prog' one has to issue: read prog @monitor()lieshell All commands and results, as they appear on your screen, will be stored in the file 'monfil' after the command: on monitor It can be turned off with 'off monitor'. The file name used can be altered by setting monfil filename This can be used to prevent overwriting the previous monitor file. @save()lieshell See write or files. @save_mat(mat,tex)lieshell save_mat(m,f) Saves matrix m in file f in Lie intern format. @get_mat(tex)lieshell get_mat(f) Returns a matrix which is stored in file f in Lie intern format. @save_string(tex,tex)lieshell save_string(s,f) Saves string s in file f in Lie intern format. @get_string(tex)lieshell get_string(f) Returns a string which is stored in file f in Lie intern format. @^(vec,vec) v^w Concatenates v and w @^(pol,pol) p^q extends all exponents of p with n_vars(q) zeros, prefixes all exponents of q with n_vars(p) zeros; returns their product @%(int,int) n%m = n modulo m @%(vec,int) v%n =v modulo n entry-wise @%(mat,int)= m%n =m modulo n entry-wise @/(int,int) n/m = the division of n by m (and rounded off towards 0 to an integer). @/(vec,int) v/n = v/n entry-wise @/(mat,int) m/n = m/n entry-wise @^(mat,mat) a^b vertical concatenation of a and b @^(int,int) a^n a to the n-th power @^(mat,int) a^n a to the n-th power @!(int) !b Boolean negation: if b==0 then 1 else 0 fi @int()silence Type indication for integer @bin()silence Type indication for big integer @vec()silence Type indication for vector @mat()silence Type indication for matrix @grp()silence Type indication for group @tex()silence Type indication for text @vid()silence Type indication for void @factor(int)int factor(n). Prints a tentative factorization of n into prime factors. (Returns void, i.e., nothing.) Only prime factors smaller than 2^15 are found. @unique(mat)array unique(m). Returns a canonical form for a matrix representing a set of vectors: it sorts the matrix and removes any multiple rows. Algorithm: heap sort. @setdefault()group setdefault g. Set default Lie group equal to g. This Lie group is used in other functions if the optional argument g is omitted. Without an argument the command setdefault prints the default group. @sort(mat)array sort(m). Returns the matrix obtained from `m' by sorting its rows into the order selected by the user (defualt is lexicographically decreasing). Algorithm: quicksort. @sort(vec)array sort(v) Returns the vector obtained from `v' by sorting its entries into decreasing order. Algorithm: quicksort. @finish() LiE/INFO.10000664000175000017500000000721510222221361011270 0ustar hakanhakan@while()lieshell ::= while do od Evaluate logical expression, if non-zero execute series and repeat. Example: a=[1,3,7,5]; i=1; while (i<=size(a) && a[i] != 7) do i=i+1 od; i result: 3 @&&(int,int) ::= && Logical AND operator, lazy in its right operand. First the left operand is evaluated. If it returns 0 (false) evaluation stops returning 0, otherwise the right operand is evaluated; if it is non-zero, 1 is returned, otherwise 0. @||(int,int) ::= || Logical OR operator, lazy in its right operand. First the left operand is evaluated. If it is non-zero (true) evaluation stops returning 1, otherwise the right operand is evaluated; if it is non-zero, 1 is returned, otherwise 0. @return()lieshell ::= return | return Terminates the current function, returning the value of the expression, if present, and void otherwise. @/(pol,int) p/n Returns the polynomial with the coefficients of p divided by n. Examples 6X[8]/2 = 3X[8]; 11X[30,4]/3 = 3X[30,4] @/(pol,vec) p/v Returns the polynomial with the exponents of p divided position-wise by the entries of v. Examples 6X[8]/[2] = 6X[4]; 11X[30,4]/[6,2] = 11X[5,2] divided by a. @*(pol,int) p*n Returns the polynomial with all exponents of p multiplied by n. Example 3X[5,2]*4 = 3X[20,8] @*(int,pol) n*p Returns the polynomial with the coefficients of p multiplied by n. Example 4*3X[5,2] = 12X[5,2] @*(pol,mat) p*m Returns the polynomial with all exponents of p multiplied to the right by m. Example 3X[5,2]*[[0,1],[3,0]] = 3X[6,5] @pol()silence Type indication for polynomials. See 'polynomial'. @|(pol,vec) p|v Searches in polynomial p the term with exponent v and returns its coefficient (0 if term is not present). Example (2X[1,2]+5X[8,7])|[8,7] = 5 p|v = n Changes the coefficien of the term with exponent v in polynomial p into n (if necessary a term is created). Example p=1X[0,0]; p|[1,2]=7 results in p = 1X[0,0]+7*X[1,2] @+=(bin,bin) a+=b replaces a by a+b. a[i]+=b replaces a[i] by a[i]+b. a[i,j]+=b replaces a[i,j] by a[i,j]+b. @+=(vec,int) a+=b appends integer b as final entry to vector a and stores the result in a. @+=(mat,vec) a+=b appends vector b as final row to matrix a and stores the result in a. @+=(tex,bin) a+=b appends text for integer b to string a and stores the result in a. @+=(tex,tex) a+=b appends string b to string a and stores the result in a. @fmt(bin,int)lieshell fmt(d,w) converts the integer d into a string of width at least w. if w < 0 then the output is left adjusted. if w > 0 then the output is right adjusted. @support(pol)polynomials support(p). Returns the matrix whose rows are the exponents of p. @polynom(mat)polynomials polynom(m). Returns the polynomial with coefficients 1 and with as exponents the rows of m. This is the same as `X m'. @row_index(mat,vec,int,int)array row_index(m,v,lb,ub) Searches for i=lb, ..., ub whether m[i]==v. The first such i is returned, or 0 if none was found. @maxobjects()lieshell maxobjects N Sets the maximum number of objects to N. The value N should be large enough to hold all objects of the computation (where each polynomial coefficient counts as separate object), but excessively large N could postpone garbage collection to the point that physical memory gets depleted. @maxnodes()lieshell maxnodes N sets the maximum number of nodes (for storing programs) to N. @listvars()lieshell listvars generates a list of the variabes defined in this session of LiE. @listfuns()lieshell listfuns generates a list of the functions defined in this session of LiE. @finish() LiE/INFO.20000664000175000017500000000035405354345044011305 0ustar hakanhakan@lieshell()@ @array()@ @weyl_group()@ Weyl group/action @represent()@ Representations/modules @group()@ Lie group/algebra @root_system()@ Root systems @polynomials()@ @partition()@ Tableaux/partitions/symmetric groups @int()@ @finish() LiE/INFO.30000664000175000017500000011363406224150265011310 0ustar hakanhakan@center(grp)group center(g) [result: torals]. Returns a matrix whose rows are semisimple elements or one parameter subgroups generating the center of g. The center of a semisimple Lie group g (always assumed to be simply connected in LiE) is a finite Abelian group isomorphic to the quotient of the weight lattice by the root lattice (for reductive groups the central torus is also included). @diagram(grp)group diagram(g). Prints the Dynkin diagram of g, also indicating the type of each simple component printed, and labeling the nodes as done by Bourbaki (for the second and further simple components the labels are given an offset so as to make them disjoint from earlier labels). The labeling of the vertices of the Dynkin diagram prescribes the order of the coordinates of root- and weight vectors used in LiE. @dim(grp)group dim(g). Returns the dimension of the Lie group g; equals dim(adjoint(g),g). @Lie_code(grp)group Lie_code(g) [result: ints]. It is required that g be a simple group or a torus; the function returns a vector [t,n] of size 2, such that Lie_group(t,n)==g. @Lie_group(int,int)group Lie_group(t,n). Returns a torus or a simple group as follows: Lie_group(0,n)= Tn Lie_group(4,n)= Dn (n>=3) Lie_group(1,n)= An (n>=1) Lie_group(5,n)= En (6<=n<=8) Lie_group(2,n)= Bn (n>=2) Lie_group(6,4)= F4 Lie_group(3,n)= Cn (n>=2) Lie_group(7,2)= G2 For any other numbers an error is indicated. This function can be useful in order to run examples over many Lie groups using a for loop. @Lie_rank(grp)group Lie_rank(g). Returns the Lie rank of g; for simple groups and tori this equals Lie_code(g)[2], while for composite groups it is the sum of the Lie ranks of the component groups. @Cartan(grp)root_system Cartan(g) [result: lin(root; weight)]. Returns the Cartan matrix of g, which is the transformation matrix from the root lattice to the weight lattice, using the bases of fundamental roots and fundamental weights respectively. Hence the i-th row of the Cartan matrix equals the i-th fundamental root, expressed as weight vector. The labeling of the fundamental roots is as indicated by diagram(g). When g is semisimple, the (i,j)-entry of the Cartan matrix is . If g contains a central torus, so that the semisimple rank s of g is differs from the Lie rank r, then the Cartan matrix is not square, as it is an s x r matrix, but all entries beyond column s are zero. @Cartan(vec,vec,grp)root_system Cartan(alpha,beta,g) [alpha,beta: root]. Returns the `Cartan product' , i.e., the integral value 2(alpha,beta)=(beta,beta), where beta must be a root, and alpha is any root vector. [This is is not an inner product because the function is not linear in beta. The function is linear in alpha however. See also inprod and norm. @Cartan_type(mat,grp)root_system Cartan_type(R,g) [R: roots]. Returns the type of the fundamental Lie subgroup whose root system is the minimal subsystem of the root system of g containing all the roots in R. A basis of fundamental roots of this subsystem may be obtained as fundam(R,g). See also closure and centr_type. @cent_roots(vec,grp)root_system cent_roots(t,g) [t: toral, result: roots]. Returns the matrix whose rows form the set of all positive roots centralising the semisimple element t of T (or the specified one parameter subgroup). Here a root alpha is said to centralise t if t commutes with all elements of the fundamental Lie subgroup of type A1 and closed subsystem of roots {alpha,-alpha} Equivalently, alpha centralises t if and only if alpha (which is a weight, and hence a map T->C ) maps t to 1. @cent_roots(mat,grp)root_system cent_roots(S,g) [S: torals, result: roots]. Returns the matrix whose rows form the set of all positive roots centralising the semisimple elements and/or one parameter subgroups represented by the rows of S. This set is the intersection of all sets cent_roots(t,g), with t traversing the rows of S. One may apply Cartan_type or fundam to the result to obtain the type, respectively the set of fundamental roots, of the centraliser. See also centr_type. @centr_type(vec,grp)group centr_type(t,g) [t: toral]. Returns the centraliser C_g(t) of the toral element t (or of the specified one parameter subgroup); effectively only the type is computed. See also cent_roots. @centr_type(mat,grp)group centr_type(S,g) [S: torals]. Returns the centraliser of the toral elements and/or one parameter subgroups of T represented by the rows of S, i.e., the intersection of the groups centr_type(t,g) for t traversing the rows of S. This function can alternatively be computed as Cartan_type(cent_roots(S,g),g). @closure(mat,grp)root_system closure(R,g) [R,result: roots]. Returns a basis of fundamental roots of the minimal closed subsystem of the root system of g that contains all the roots in R; the basis consisting of positive (for g) roots only is chosen. @det_Cartan(grp)root_system det_Cartan(g). Returns the determinant of Cartan (g). This number is the index of the root lattice in the weight lattice, and it is also the order of the center of g. See also i_Cartan. @dom_weights(vec,grp)root_system dom_weights(lambda,g) [lambda: weight, result: weights]. Returns the set of dominant weights lying under lambda. This is equal to the set of weights occurring in dom_char (lambda,g). @fundam(mat,grp)root_system fundam(R,g) [R,result: roots]. Returns a basis of fundamental roots of the minimal subsystem of the root system of g that contains all the roots in R; the basis consisting of positive (for g) roots only is chosen. The order in which the fundamental roots are returned is compatible with the standard labeling for a root system of type Cartan_type(R,g). @high_root(grp)root_system high_root(g) [result: root]. Returns the highest root of the root system of the group g, which must have exactly one simple component (for otherwise there exists no highest root). This root is the last row of pos_roots(g). See also adjoint. @i_Cartan(grp)root_system i_Cartan(g) [result: lin(weight,root)]. Returns det_Cartan(g) times the inverse of Cartan(g). The scalar factor det_Cartan(g) is required in order to keep all matrix entries integral. To transform an element of the root lattice, given as lambda in weight coordinates, to root coordinates, compute lambda*i_Cartan(g)/det_Cartan(g). @inprod(vec,vec,grp)root_system inprod(x,y,g) [x,y: root]. Returns the Weyl group invariant inner product of x and y. The inner product is normalised in such a way that for each simple component of g the short roots x have inprod(x,x) = 2. @norm(vec,grp)root_system norm(alpha,g) [alpha: root]. Returns the norm inprod(alpha,alpha) of the root vector alpha (it would be more accurate, but less convenient, to call this the "squared norm"). When alpha is a root, the value is one of {2, 4, 6}, and the inner product is chosen such that for each simple component the short roots have norm 2. Note that this normalisation differs from that used by Bourbaki in the case of groups of type Bn, as the short roots are given norm 1 there. @n_pos_roots(grp)root_system n_pos_roots(g). Returns the number of positive roots of the root system of g, which is equal to n_rows(pos_roots(g)). The number of all roots is twice as much, and can also be computed as dim(g)-Lie_rank(g). @pos_roots(grp)root_system pos_roots(g) [result: roots]. Returns a matrix whose rows are the positive roots of g. The first rows are the fundamental roots (i.e., the top r rows form the matrix id(r), and if g is simple the last row, which has index n_pos_roots(g), is high_root(g). @Bruhat_desc(vec,grp)weyl_group Bruhat_desc(w,g) [w: Weyl word, result: Weyl words]. Returns the set of Bruhat descendents of w, each one represented by a reduced Weyl word. The Weyl word chosen for a Bruhat descendent is the unique one which is obtainable by omitting one of the fundamental reflections occurring in the Weyl word reduce(w). @Bruhat_desc(vec,vec,grp)weyl_group Bruhat_desc(v,w,g) [v,w: Weyl word, result: Weyl words]. Returns the set of Bruhat descendents w' of w which lie above v in the Bruhat ordering. This is useful in generating all elements between v and w in the Bruhat ordering. @Bruhat_leq(vec,vec,grp)weyl_group Bruhat_leq(v,w,g) [v,w: Weyl word]. Returns the value 1 if v<=w in the Bruhat order, and 0 otherwise. @canonical(vec,grp)weyl_group canonical(w,g) [v,result: Weyl word]. Returns the canonical Weyl word representing the same Weyl group element as w, which is the lexicographically first reduced expression for that element. @canonical(mat,grp)weyl_group canonical(m,g) [m,result: Weyl words]. Returns the matrix obtained by replacing each row w by canonical(w,g), filling out the row with zeros if necessary. This is useful in combination with unique when handling sets of Weyl words. @dominant(vec,grp)weyl_group dominant(lambda,g) [lambda,result: weight]. Returns the unique dominant weight in the Weyl group orbit of the weight lambda. @dominant(mat,grp)weyl_group dominant(m,g) [m,result: weights]. Returns the matrix obtained by replacing each row of m by the unique dominant weight in its Weyl group orbit. @dominant(pol,grp)weyl_group dominant(p,g) [p,result: weights]. Returns the polynomial obtained by replacing each exponent of p by the unique dominant weight in its Weyl group orbit. @exponents(grp)weyl_group exponents(g) [result: ints]. Returns the exponents of the given Lie group. For composite groups the exponents are not necessarily increasing, as they are grouped according to the simple factors of the group, with the exponents for the central torus (all zeros) at the end. @filter_dom(mat,grp)weyl_group filter_dom(m,g) [m,result: weights]. Returns the matrix obtained by casting away all rows of m that are not dominant weights. @filter_dom(pol,grp)weyl_group filter_dom(p,g) [p,result: weights]. Returns the polynomial obtained by casting away all terms of p whose exponents are not dominant weights. @KL_poly(vec,vec,grp)weyl_group KL_poly(x,y,g) [x,y: Weyl word, result: polynomial]. Returns the Kazhdan-Lusztig polynomial P_{x,y}. @length(vec,grp)weyl_group length(w,g) [w: Weyl word]. Returns the length of the Weyl group element w. We have length(w)<=size(w), with equality if and only if w == reduce(w,g). @long_word(vec,grp)weyl_group long_word(g) [result: Weyl word]. Returns a Weyl word for longest element of the Weyl group. @l_reduce(vec,vec,grp)weyl_group l_reduce(l,w,g) [l: ints, w,result: Weyl word]. The set l determines a subgroup W_l of W generated by the set of fundamental reflections { r_i | i in l }. The function returns a Weyl word for the distinguished representative (element of minimal length) of the left coset `W_l w'. This Weyl word is obtained by deleting certain entries from w; in particular, if w is already a reduced expression for the distinguished representative, then w itself is returned. @lr_reduce(vec,vec,vec,grp)weyl_group lr_reduce(l,w,r,g) [l,r: ints, w,result: Weyl word]. The sets l and r determine subgroups W_l and W_r of W generated by the sets of fundamental reflections { r_i | i in l } respectively { r_i | i in r }. The function returns a Weyl word for the distinguished representative (element of minimal length) of the double coset `W_l w W_r'. This Weyl word is obtained by deleting certain entries from w; in particular, if w is already a reduced expression for the distinguished representative, then w itself is returned. @orbit(vec,mat)weyl_group orbit(v,M) [result: vectors]. Here v is a vector with an arbitrary interpretation, and M is a matrix whose column size c equals size(v), and whose row size is a multiple of c, say kc. We interpret M as a collection of k square matrices of size c x c, vertically concatenated. The function orbit attempts to compute the orbit of v under the group generated by the collection of matrices, i.e., a minimal set V of vectors containing v and closed under right multiplication by any of the matrices in the given collection. As the orbit might be infinite, and the algorithm has no means to detect this situation, it gives up when more than 1000 vectors in the orbit have been computed. For larger orbits, see orbit(n,v,M ), for Weyl group orbits see W_orbit. @orbit(int,vec,mat)weyl_group orbit(n,v,M) [result: vectors]. This function operates in the same way as orbit(v,m), but n replaces the limit of 1000 elements in the orbit. Warning: orbit uses allocates space at the beginning for the maximal number n of vectors allowed in the orbit; therefore one shouldn't go overboard on choosing the limit n. @reduce(vec,grp)weyl_group reduce(w,g) [w,result: Weyl word]. Returns a Weyl word of minimal length representing the same element of W as w. This Weyl word is obtained by deleting certain entries from w; in particular, if w is already a reduced expression, then w itself is returned. See also canonical, l_reduce, r_reduce and lr_reduce. @reflection(vec,grp)weyl_group reflection(vec alpha,g) [alpha: root, result: lin(weight,weight)]. Returns the matrix of the reflection of the weight lattice in the hyperplane perpendicular to the root ff, expressed on the basis of fundamental weights. See also W_action . @R_poly(vec,vec,grp)weyl_group R_poly(x,y,g): pol [x,y: Weyl word, result: polynomial]. Returns the value of the R-polynomial R_{x,y}. @r_reduce(vec,vec,grp)weyl_group r_reduce(w,r,g) [w,result: Weyl word, r: ints]. The set r determines a subgroup Wr of W generated by the set of fundamental reflections { r_i | i in r }. The function returns a Weyl word for the distinguished representative of the right coset `w W_r'. This Weyl word is obtained by deleting certain entries from w; in particular, if w is already a reduced expression for the distinguished representative, then w itself is returned. @W_action(vec,grp)weyl_group W_action(w,g) [w: Weyl word, result: lin(weight,weight)]. Returns the matrix giving the action of the Weyl group element w in W on the weight lattice, expressed on the basis of fundamental weights. See also reflection, W_rt_action, and W_word. @W_action(vec,vec,grp)weyl_group W_action(lambda,w,g) [lambda,result: weight, w: Weyl word]. Returns the weight that is the image `lambda.w' of the weight lambda under the action of the Weyl group element w. @W_action(mat,vec,grp)weyl_group W_action(m,w,g) [m,result: weights, w: Weyl word]. Returns the matrix obtained by replacing each row lambda of m by W_action(lambda,w,g); this matrix is equal to m*W_action(w,g), while conversely W_action(w,g) equals W_action(id(Lie_rank(g)),w,g). @W_action(pol,vec,grp)weyl_group W_action(p,w,g) [p,result: weights, w: Weyl word]. Returns the polynomial obtained by replacing each exponent lambda of p by W_action(lambda,w,g); this polynomial is equal to p*W_action(w,g). @W_orbit(vec,grp)weyl_group W_orbit(lambda,g) [lambda: weight, result: weights]. Returns the orbit of the weight lambda under the Weyl group of g. @W_orbit(pol,grp)weyl_group W_orbit(pol p,g) [p,result: weights]. Returns the polynomial obtained by summing over all terms `n X lambda' of p the polynomial `n X W_orbit(lambda,g)'; the latter polynomial contains each weight in the W-orbit of lambda exactly once and with coefficient n. This operation can be used for instance to compute the full character polynomial of a module from its dominant character module. @W_orbit_size(vec,grp)weyl_group W_orbit_size(lambda,g) [lambda: weight, result: weights]. Returns the size of the orbit of the weight lamnda under the Weyl group of g. This size can also be computed as W_order(g)/W_order(I,g), where I is a vector whose entries indicate the positions at which the vector dominant(lambda) has zero entries. @W_order(grp)weyl_group W_order(g). (Weyl group order) Returns the order of the Weyl group of g. @W_order(vec,grp)weyl_group W_order(I,g) [I: ints]. Returns the order of the subgroup W_I of the Weyl group of g generated by the set of fundamental reflections { r_i | i in I }. This subgroup is the stabiliser subgroup of any weight vector that has zero entries precisely at positions i for which i in I. @W_rt_action(vec,grp)weyl_group W_rt_action(w,g) [w: Weyl word, result: lin(root,root)]. (Weyl root action) Returns the matrix giving the action of the Weyl group element w on the root lattice, expressed on the basis of fundamental roots. @W_rt_action(vec,vec,grp)weyl_group W_rt_action(vec alpha,w,g) [alpha: root, w: Weyl word]. Returns the root that is the image `alpha.w' of the root vector alpha under the Weyl group element w. @W_rt_action(mat,vec,grp)weyl_group W_rt_action(m,w,g) [m,result: roots, w: Weyl word]. Returns the matrix obtained by replacing each row alpha of m by W_rt_action(alpha,w,g); this matrix is equal to m*W_rt_action(w,g), while conversely W_rt_action(w,g) equals W_rt_action(id(Lie_rank(g)),w,g). @W_rt_orbit(vec,grp)weyl_group W_rt_orbit(alpha,g) [alpha: root, result: roots]. (Weyl root orbit) Returns the orbit of the root vector alpha under the Weyl group of g. @W_word(vec,grp)weyl_group W_word(lambda,g) [lambda: weight, result: Weyl word]. Returns a Weyl word for a Weyl group element w whose action sends lambda to a dominant weight. In fact, the canonical Weyl word for w is returned, while w is the distinguished representative of its right coset `w W_S' , where W_S is the stabiliser of dominant(lambda,g). @W_word(mat,grp)weyl_group W_word(m,g) [m: lin(weight,weight), result: Weyl word]. Returns the canonical Weyl word for the Weyl group element w, if it exists, whose action on the weight lattice is given by the square matrix m, i.e., such that W_action(w,g)==m. @class_ord(vec)partition class_ord(lambda) [lambda: partition]. Returns the order of the conjuga- tion class in S_n of permutations of cycle type lambda (for n = |lambda|, the sum of the parts of lambda). @from_part(vec)partition from_part(lambda) [lambda: partition, result: weight]. Let n be the number of parts of lambda (trailing zeros are significant here) then the function returns the weight for a group of type A_{n-1} (i.e., for SL_n ) corresponding to lambda, expressed on the basis of fundamental weights. See also to_part. @from_part(mat)partition from_part(m) [m: partitions, result: weights]. Replaces each row lambda of m by from_part(lambda). @from_part(pol)partition from_part(p) [p: partitions, result: weights]. Replaces each exponent lambda occurring in p by from_part(lambda). @next_part(vec)partition next_part(lambda) [lambda,result: partition]. Returns the next partition of |lambda| in reverse lexicographic order. If lambda is the last one, i.e., if lambda[1,1,...,1], it will return lambda again. See also partitions. @next_perm(vec)partition next_perm(p) [p,result: ints]. Returns the next permutation of the entries of p, in lexicographical order. If p is the last such permutation, i.e., if the entries of p are decreasing, then p itself will be returned again. If there are repetitions among the entries of p, then this function will not attempt to permute identical entries, and in such cases it will take fewer applications of next_perm to go from the weakly decreasing order to the weakly increasing order. See also sym_orbit. @next_tabl(vec)partition next_tabl(T) [T,result: tableau]. Returns the lexicographically next Young tableau of the same shape as T. See also tableaux. @next_tabl(vec)partition n_tabl(lambda) [lambda: partition]. Returns the number of Young tableaux of shape lambda. @partitions(int)partition partitions(n) [result: partitions]. Returns a matrix whose rows are the partitions of n in reverse lexicographic order, and extended by zeros to length n. See also next_part. @print_tab(vec)partition print_tab(T) [T: tableau]. Displays the Young tableau encoded by T in 2-dimensional form. @RS(vec)partition RS(p) [p: permutation, result: tableaux]. Returns the pair of Young tableaux corresponding to the permutation p by the Robinson-Schensted correspondence; the result is represented as a 2-row matrix. @RS(vec,vec)partition RS(P,Q) [P,Q: tableau, result: permutation]. Returns the permutation corresponding to the pair of Young tableaux P,Q (which must have the same shape) by the Robinson-Schensted correspondence. @sign_part(vec)partition sign_part(lambda) [lambda: partition]. Returns the sign (+1 or 1) of permutations of cycle type lambda. @shape(vec)partition shape(T) [T : tableau, result: partition]. Returns the shape of the Young tableau T. @sym_char(vec)partition sym_char(lambda) [lambda: partition, result: character]. (Symmetric group character) Let n=|lambda|; the function returns the character polynomial of the character chi_lambda of the symmetric group S_n corresponding to the partition lambda. @sym_char(vec,vec)partition sym_char(lambda,mu) [lambda,mu: partition]. We should have |lambda|=|mu|; the function returns the (integral) value chi_lambda(mu) of the character of the symmetric group S_{|mu|} corresponding to on the conjugacy class with cycle type lambda. @sym_orbit(vec)partition sym_orbit(v) [result: vectors]. (Symmetric group orbit) Let n = size(v). The symmetric group on n letters acts on Z^n by permuting the coordinates; the function returns the orbit of v in this action. The rows of the result are ordered lexicographically. See also next_perm. @tableaux(vec)partition tableaux(lambda) [lambda: partition, result: tableaux]. Returns a matrix whose rows encode the set of all Young tableaux of shape lambda, in lexicographic order. @to_part(vec)partition to_part(v) [v: weight, result: partition]. Let n = size(v), then v is interpreted as a weight for a group of type A_n (i.e., for SL_{n+1}); the expression of that weight in n+1 partition coordinates is returned. When v is dominant, this is a partition with n+1 parts. See also from_part. @to_part(mat)partition to_part(m) [m: weights, result: partitions]. Replaces each row v of m by to_part(v). @to_part(pol)partition to_part(p) [p: weights, result: partitions]. Replaces each exponent v occurring in p by to_part(v). @trans_part(vec)partition trans_part(lambda) [lambda,result: partition]. Returns the transpose partition of lambda. @Adams(int,vec,grp)represent Adams(n,lambda,g) [lambda: weight, result: decomposition]. Returns the decomposition polynomial of the virtual module obtained by applying the n-th Adams operator to V_lambda. The result is the same as that computed by `v_decomp(dom_char(lambda,g)*n,g)'. This function is used in plethysm, sym_tensor, and alt_tensor. @Adams(int,pol,grp)represent Adams(n,p,g) [p: decomposition, result: decomposition]. This is like Adams(n,lambda,g), but with the irreducible module V_lambda replaced by the module with decomposition polynomial p. @adjoint(grp)represent adjoint(g) [result: decomposition]. Returns the decomposition polynomial of the adjoint representation of g. For simple groups the adjoint representation is irreducible and the result therefore has a single term; the highest weight of the adjoint representation can then be obtained as expon(adjoint(g),1). Since the non-zero weights of the adjoint representation are precisely the roots, this highest weight is equal to high_root(g)*Cartan(g). @alt_tensor(int,vec,grp)represent alt_tensor(n,lambda,g) [lambda: weight, result: decomposition]. (alternating tensor power) Returns the decomposition polynomial of the n-th alternating tensor power (also called n-th exterior power) of V_lambda. See also sym_tensor and plethysm. @alt_tensor(int,pol,grp)represent alt_tensor(n,p,g) [p,result: decomposition]. This is similar to alt_tensor(n,lambda,g), but with the irreducible module V_lambda replaced by the module with decomposition polynomial p. @alt_dom(pol,vec,grp)represent alt_dom(p,w,g) [p,result: weights, w: Weyl word]. (alternating dominant) Starting with the polynomial p, the following operation is repeatedly applied, taking for i the successive entries of the Weyl word w, reading from left to right. For any term `n X^lambda' let lambda[i]= be its coefficient of omega_i; the term is unaltered if lambda[i] >= 0, it is removed if lambda[i] = -1, and it is replaced by `n X(W_action(lambda+omega_i,[i])-omega_i)' if lambda[i] <= -2. (The exponent of the latter monomial could also have been written as `W_action(lambda,[i])-alpha_i' or as `lambda-(lambda[i]+1)*alpha_i'.) As a result of the operation for i, the coefficient lambda[i] is made non-negative without affecting the image Demazure(p,[i]) under the Demazure operator, and hence also without changing alt_W_sum(p). The final result of alt_dom should be the same when taking for w different reduced Weyl words for the same element of W . @alt_dom(vec,vec,grp)represent alt_dom(lambda,w,g) [lambda: weight, w: Weyl word, result: weights]. Returns `alt_dom(X lambda,w,g)'. @alt_dom(pol,grp)represent alt_dom(p,g) [p,result: weights]. This is equivalent to (but somewhat faster than) `alt_dom(p,long_word(g),g)'. The resulting polynomial q can be charaterised as the unique polynomial with only dominant exponents which has alt_W_sum(q)==alt_W_sum(p). If p is a character polynomial, then q is the corresponding decomposition polynomial. @alt_dom(vec,grp)represent alt_dom(lambda,g) [lambda: weight, result: weights]. Returns `alt_dom(X lambda,g)'. @alt_W_sum(pol,grp)represent alt_W_sum(p,g) [p,result: weights]. (alternating Weyl sum) Returns the alternating Weyl sum J(p) of p, defined by sum_{w in W} (-1)^length(w) W_action(X rho * p,w)*X(-rho) where rho=all_one(Lie_rank) (the half sum of the positive roots). The number of terms generated is a multiple of W_order(g), so it may not be wise to call this function if W_order(g) is very large. @alt_W_sum(vec,grp)represent alt_W_sum(lambda,g) [lambda: weight, result: weights]. Returns `alt_W_sum(X lambda,g)'. @branch(vec,grp,mat,grp)represent branch(lambda,h,m,g) [lambda: weight, m: lin(weight,weight), result: decomposition]. Returns the decomposition polynomial of the restriction to h of V_lambda, with respect to the restriction matrix m. Here the matrix m is such that any weight mu (expressed on the basis of fundamental weights for g), when restricted to the maximal torus of h becomes the weight mu*m (expressed on the basis of fundamental weights for h). In many cases the restriction matrix can be obtained by use of res_mat. See also decomp for a warning for in case memory overflow should occur during branch. @branch(pol,grp,mat,grp)represent branch(p,h,m,g) [p,result: decomposition, m: lin(weight,weight)]. This is like branch(lambda,h,m,g), but with the irreducible module V_lambda replaced by the module with decomposition polynomial p. @collect(pol,grp,mat,grp)represent collect(p,h,l,g) [p,result: decomposition, l: lin(weight,weight)]. This function attempts to perform the inverse operation of branch, namely to reconstruct a g-module from its restriction to h. This is not generally possible unless the restriction matrix is invertible, and in particular g and h have the same Lie rank. When a restriction matrix m has an inverse l, and the h-module with decomposition polynomial p is equal to some restriction branch(q,h,m,g) of a g-module via m, then the decomposition polynomial q can be computed as collect(p,h,l,g). @collect(pol,grp,mat,int,grp)represent collect(p,h,l,n,g) [p,result: decomposition, l: lin(weight,weight)]. An obvious limitation of the previous version of collect is that it is only applicable for restriction matrices which are invertible over the integers; certain restriction matrices are invertible, but only over the rational numbers. For these cases this extended version is provided. Since LiE cannot handle matrices with rational entries, a common denominator n of all the entries of the inverse restriction matrix has to be factored out and passed as a separate argument, so that the scaled inverse matrix l has only integer coefficients. For all weights to which l is applied the image should be divisible by n, or else an error will be reported; apart from this, the extended version of collect operates in the same way as the previous one. @contragr(vec,grp)represent contragr(lambda,g) [lambda,result: weight]. Yields the highest weight of the contragredient (or dual) representation V_lambda^* of V_lambda, which equals dominant (-lambda,g). @contragr(pol,grp)represent contragr(p,g) [p,result: decomposition]. Returns the decomposition polynomial of the contragredient representation of the module with decomposition polynomial p. @decomp(pol,grp)represent decomp(d,g) [d: dominant, result: decomposition]. Returns the decomposition polynomial of the g-module with dominant character polynomial d; it is the inverse operation of dom_char. See also v_decomp. @Demazure(pol,vec,grp)represent Demazure(p,w,g) [p,result: weights, w: Weyl word]. Starting with the polynomial p, repeatedly apply the Demazure operator M_{alpha_i}, taking for i the successive entries of the Weyl word w, from left to right. The final result of Demazure should be the same when taking for w different reduced Weyl words for the same element of W. @Demazure(vec,vec,grp)represent Demazure(lambda,w,g) [lambda: weight, w: Weyl word, result: weights]. Returns `Demazure(X lambda,w,g)'. @Demazure(pol,grp)represent Demazure(p,g) [p,result: weights]. This is an abbreviation for the call Demazure (p,long_word(g),g). The resulting polynomial q can be characterised as the unique W-invariant polynomial which has J(q) = J(p). In fact, due to Demazure's character formula, q is the character polynomial of the module with decomposition polynomial p (provided all exponents of p were dominant). @Demazure(vec,grp)represent Demazure(lambda,g) [lambda: weight, w: Weyl word, result: weights]. Returns `Demazure (X lambda,g)'. @dim(vec,grp)represent dim (lambda,g) [lambda: weight]. Returns the dimension of the representation V_lambda. @dim(pol,grp)represent dim(p,g) [p: decomposition]. Returns the dimension of the g-module with decomposition polynomial p. @dom_char(vec,grp)represent dom_char(lambda,g) [lambda: weight, result: dominant]. (dominant character) Returns the polynomial representing the dominant part of the character of the g-module V_lambda. @dom_char(vec,vec,grp)represent dom_char(lambda,mu,g) [lambda,mu: weight]. Returns the coefficient of `X mu' in the character polynomial of V_lambda. The weight lambda should be dominant, but mu may be any weight. @dom_char(pol,grp)represent dom_char(p,g) [p: decomposition, result: dominant]. This is like dom_char(lambda,g), but with the irreducible module V_lambda replaced by the module with decomposition polynomial p. @dom_char(pol,vec,grp)represent dom_char(p,mu,g) [p: decomposition, mu:weight, result: dominant]. Returns the coefficient of `X mu' in the character polynomial of the module with decomposition polynomial p. @LR_tensor(vec,vec)represent LR_tensor(lambda,mu) [lambda,mu: partition result: decomposition]. (Littlewood-Richardson tensor) The partitions lambda and mu, which must have the same number of parts, say n, are interpreted as dominant weights for the group SL_n of type A_{n-1}, expressed in partition coordinates. The decomposition polynomial of the tensor product of the corresponding highest weight modules is computed using the Littlewood-Richardson rule, where the exponents in the result are again expressed in partition coordinates. Note that extending lambda and mu by zeros can be significant: partitions with more than n non-zero parts may appear as exponents of new terms, while existing terms will reappear in zero- extended form. The total number of non-zero parts is bounded however by the number in lambda and mu taken together, so eventually the number of terms will stabilise; the limiting case corresponds to the decomposition of the Young product of the representations corresponding to lambda and mu in the representation theory of the symmetric groups. @LR_tensor(pol,pol)represent LR_tensor(p,q) [p,q,result: decomposition]. Returns the decomposition poly- nomial of the tensor produce of the SL_n-modules with respective decompo- sition polynomials p and q, computed using the Littlewood-Richardson rule; all polynomials have their exponents in partition coordinates. @max_sub(grp)represent max_sub(g). Returns the types of the maximal proper subgroups of g, represented textually as comma separated list; the list is obtained from a small database. The group g must be simple and of rank <= 8. Types for which more than one conjugacy class of subgroups exist have repeated occurrences in the list. See also res_mat. @max_sub(int,grp) max_sub(i,g). Returns the type of the i-th maximal proper subgroup of g in the list max_sub(g). The group g must be simple and of rank <= 8. See also res_mat. @plethysm(vec,vec,grp)represent plethysm(lambda,mu,g) [lambda: partition, mu: weight, result: decomposition]. Returns the decomposition polynomial of the g-module of the plethysm of of V_m corresponding to the partition lambda. @plethysm(vec,pol,grp)represent plethysm(lambda,p,g) [lambda: partition, p,result: decomposition]. This is similar to plethysm(lambda,mu,g), but with the irreducible module V_mu replaced by the module with decomposition polynomial p. @p_tensor(int,vec,grp)represent p_tensor(n,lambda,g) [lambda: weight, result: decomposition]. Returns the decomposition polynomial of the n-th tensor power of V_lambda. @p_tensor(int,pol,grp)represent p_tensor(n,p,g) [p,result: decomposition]. Returns the decomposition polynomial of the n-th tensor power of the g-module with decomposition polynomial p. @res_mat(mat,grp)represent res_mat(R,g) [R: roots, result: lin(weight,weight)]. (restriction matrix) It is assumed that the set R consists of roots forming a fundamental basis for a closed subsystem Psi of the root system Phi of g (as for instance obtained by a call of closure). The function returns the restriction matrix for the fundamental Lie subgroup of g with root system Psi. Although the function checks whether the rows of R are indeed roots, and whether they are linearly independent, it does not test whether they are positive roots and whether their mutual inner products are non-positive; these conditions should be met however in order to obtain a result suitable for use with branch and collect. If the number m of roots is strictly less than the Lie rank r of g, and one is in fact interested in the semisimple subgroup with the given root system Psi, then it suffices to simply discard the final r-m columns. @res_mat(grp,grp)represent res_mat(h,g) [result: lin(weight,weight)]. Returns the restriction matrix for the maximal proper subgroup with type h of g, which is obtained from a small database. The group g must be simple and of rank <= 8. In case more than one non-conjugate subgroups of type h exist, the restriction matrix for the first one in the list is returned; in case no such subgroup exists, an error is reported. See also max_sub. @res_mat(grp,int,grp)represent res_mat(h,i,g) [result: lin(weight,weight)]. Returns the restriction matrix for the i-th maximal proper subgroup with type h of g, which is obtained from a small database. The group g must be simple and of rank <= 8. See also max_sub. @spectrum(vec,vec,grp)represent spectrum(lambda,t,g) [lambda: weight, t: toral]. Let n be the last entry of t, then the toral element t will act in any representation of g as a diagonalisable transformation all of whose eigenvalues are n-th roots of unity. The function returns a polynomial in one indeterminate, in which the coefficient of the monomial `X i' is the multiplicity of the eigenvalue zeta^i in the action of the toral element t on the irreducible g-module V_lambda, where i is the complex number e^{2*pi/n}. @spectrum(pol,vec,grp)represent spectrum(p,t,g) [p: decomposition, t: toral]. This is similar to spectrum (lambda,t,g), but with the irreducible module V_lambda replaced by the module with decomposition polynomial p. @sym_tensor(int,vec,grp)represent sym_tensor(n,lambda,g) [lambda: weight, result: decomposition]. (symmetric tensor power) Returns the decomposition polynomial of the n-th symmetric tensor power of V_lambda. See also alt_tensor and plethysm. @sym_tensor(int,pol,grp)represent sym_tensor(n,p,g) [p,result: decomposition]. This is similar to sym_tensor(n,,g), but with the irreducible module V_lambda replaced by the module with decomposition polynomial p. @tensor(vec,vec,grp)represent tensor(lambda,mu,g) [lambda,mu: weight, result: decomposition]. Returns the decomposition polynomial of the tensor product of V_lambda and V_mu. For groups of type A_n, see also LR_tensor. @tensor(vec,vec,vec,grp)represent tensor(lambda,mu,nu,g) [lambda,mu,nu: weight]. Returns the coefficient of the monomial `X nu' in tensor(lambda,mu,g). @tensor(pol,pol,grp)represent tensor(p,q,g) [p,q,result: decomposition]. Returns the decomposition polynomial of the tensor product of the g-modules with respective decomposition polynomials p and q. @tensor(pol,pol,vec,grp)represent tensor(p,q,nu,g) [p,q,result: decomposition, nu: weight]. Returns the coefficient of the monomial `X nu' in tensor(p,q,g). @v_decomp(pol,grp)represent v_decomp(d,g) [d: dominant, result: decomposition]. (virtual decomposition) Returns the virtual decomposition polynomial of the virtual g-module with dominant character polynomial d. @v_decomp(vec,grp)represent v_decomp(lambda,g) [lambda: weight, result: decomposition]. This is equivalent to v_decomp(X lambda,g). LiE/INFO.40000664000175000017500000000063305354345045011310 0ustar hakanhakan@tableau()partition A (Young) tableau is encoded in LiE by a vector v, such that v[i] records the row number of the entry i in the Young tableau. The numbers v[i] should be positive, and in any initial part of v no number may occur more often than a lower number. The 2-dimensional form can be retrieved by the function call print_tab(v). Example v=[1,2,1,1,2,1,3]; print_tab(v) 1 3 4 6 2 5 7 @finish() LiE/LEARN0000664000175000017500000010631506235121054011247 0ustar hakanhakan@matrix Matrix A matrix can either be interpreted as a linear transformation (acting by right-multiplication on row vectors), or as a set of vectors, in which case each row of the matrix represents a vector in the set, or in a special way such as a character table. For instance, a matrix representing a set of roots will be termed a root matrix. See also orbit matrix and restriction matrix. @polynomial Polynomial A polynomial may either just represent itself, i.e., a Lau- rent polynomial (for instance in the case of the Kazhdan-Lusztig poly- nomials, which incidentally are always ordinary polynomials), or it may encode a set of vectors of equal size, with multiplicities. In the latter case each term represents the occurrence of its exponent in the indicated set (such exponents are always interpreted as a weights), occurring with multiplicity equal to the coefficient of the term. On their turn, sets of weights with multiplicities may have different in- terpretations, leading to a further distinction between polynomials. Three important such interpretations are that of decomposition poly- nomials, character polynomials, and dominant character polynomials. @vector Vector A vector may represent an element of a vector space (or rather of a free Z-module, since its entries must be integral), such as the weight space, or it may just be interpreted as a set or sequence of integers. In the former case it is always to be interpreted as a row vector, so that matrices are to be applied from the right. In either case there are a further distinctions as to how the vector is to be interpreted. See also root vector, weight vector, Weyl word, partition and toral element. @central torus Central torus The center of any reductive Lie group g is the direct product of a torus and a finite group, the former (which is clearly the connected component of the center) is called the central torus of g. For the groups LiE deals with this central torus is even a direct factor of g itself, the other factor being the semisimple part of g. @diagram Diagram The (Dynkin) diagram of a semisimple Lie group is a graph indicating the isomorphism type of the group, the number of vertices is equal to the (semisimple) Lie rank, and the number of connected components of the diagram is equal to the number of simple factors of the group. The vertices are labeled with positive integer numbers, following the conventions of . The diagram represents the information contained in the Cartan matrix of the group in a compact form. @fundamental lie subgroup Fundamental Lie subgroup A closed subgroup h of a Lie group g is called fundamental if it contains a maximal torus of g. If h contains T and is reductive, it is determined by the set of roots in the root system of g that are also roots of h, these form a closed subsystem of roots. @general linear group General Linear group The group of all invertible linear transfor- mations of a vector space V is called the general linear group of V , written GL(V ). Up to isomorphism this depends only on n = dim V , and this group is also written as GL(n, C) (assuming the vector space is over C). This group is a Lie group, and any Lie group homomor- phism of some Lie group g to GL(V ) is called a representation of that Lie group on the vector space V . See also special linear group. @lie algebra Lie algebra A finite-dimensional vector space V supplied with a bi- linear operation [ , ]: V*V->V satisfying [x, y] = - [y, x] and [[x, y], z]+[[y, z], x]+[[z, x], y] = 0 for all x, y, z element V (anti-commutativity and the Jacobi identity, respectively) is called a Lie algebra. Every Lie group defines a Lie algebra structure on the tangent space to the group at the identity element. Although Lie algebras play no explicit role in this package, the representation theory of simply connected reductive complex Lie groups which LiE deals with coincides with the representation theory of reductive Lie algebras over C. @lie group Lie group A group is called a Lie group if its underlying set is a differentiable variety, and the multiplication and inversion maps are differentiable. The group is called complex, connected, simply con- nected, etc., if the variety is respectively complex, connected, simply connected, etc. Each reductive complex Lie group is an algebraic group and the representation theory can be dealt with in an entirely algebraic manner. @lie rank Lie rank The dimension of a maximal torus of g is called the Lie rank of g. @maximal torus Maximal torus A torus that is not properly contained in any other torus within g is called a maximal torus of g. If g is a reductive Lie group, such tori exist and any two are conjugate. In LiE, we always assume a fixed maximal torus T of g to be chosen, weights and roots are defined with respect to T . @reductive group Reductive group A group is reductive if each of its finite dimensional representations decomposes into a direct sum of irreducible represen- tations. A connected reductive complex Lie group g is isomorphic to the quotient of the direct product of a simply connected semisimple group and a torus by a finite central subgroup. An example is the General Linear group GL(n, C). The (images of) the semisimple fac- tor and the torus can be found as the commutator subgroup g0 of g and the central torus of g respectively. In LiE, the type group always refers to a group that itself is a direct product of a simply connected semisimple group and a torus (so no quotient is involved). @semisimple element Semisimple element All conjugates of elements of the torus T are called semisimple elements (not to be confused with the term semi- simple for groups), in any representation of g they correspond to diag- onalisable transformations. Hence each conjugacy class of semisimple elements has representatives in T , and some elements of T namely those of finite order, can be represented in LiE, see in Section 3.2 under toral element. @semisimple group Semisimple group A connected reductive Lie group is called semi- simple if it contains no non-trivial central torus, or equivalently if it is equal to its commutator subgroup. Note that a non-trivial semisimple group necessarily contains non-semisimple elements. @semisimple rank Semisimple rank The semisimple rank of a group g is the Lie rank of its semisimple part, or stated differently, the Lie rank of g minus the dimension of its central torus. @special linear group Special Linear group For a vector space M the Special Linear group SL(M ) is the closed Lie subgroup of the General Linear group GL(M ) of all transformations with determinant equal to 1. It is the commu- tator subgroup of GL(M ). @torus Torus A group which is isomorphic to (C*)^n for some n is called a torus (plural: tori), it is a reductive Lie group of dimension n. Any closed connected subgroup of a Lie group g all of whose elements are semisimple is a torus, called a torus of g. Every torus of g is contained in a maximal torus, and every maximal torus is conjugate to T , the fixed maximal torus. See also semisimple element. A fundamental property of a torus is that all of its irreducible representations are 1- dimensional. Since in such a representation of T each element acts as a scalar, the representation is essentially given by an algebraic group morphism T->C* , a so-called weight. Any representation of g may be restricted to a representation of T , as such it decomposes into 1- dimensional representations. The resulting formal sum of weights is called the (formal) character of the representation with respect to T . This formal sum of weights can be represented by a polynomial, which is then called a character polynomial. @cartan matrix Cartan matrix The matrix (ai, aj) 1<=i,j<=s is called the Cartan ma- trix (of the semisimple part) of g, its rows express the fundamental roots on the basis of fundamental weights. @cartan type Cartan type The Cartan type of a closed subsystem of roots of is the type of the fundamental Lie subgroup of g whose root system is . @closed subsystem Closed subsystem Given a root system R, a closed subsystem S 1 is a subset that is itself a root system, and has the property that when- ever ai + bi element for ai, bi element R then ai + bi element S . If R is the root system of g, then every closed subsystem corresponds to a fundamental Lie subgroup of g. @fundamental reflection Fundamental reflection For a chosen set of fundamental roots a1,...,as the reflections in the hyperplanes perpendicular to these roots are called fundamental reflections, they are often denoted by r1,...,rs. These reflections generate the Weyl group. @fundamental root Fundamental root It is often assumed that a subset of the roots has been chosen as the set of fundamental roots, which are then denoted by a1 ,..., as. This set must form a basis of the root lattice such that any root can be expressed as a linear combination of them with either all positive or all negative integer coefficients. This is the basis on which root vectors are expressed. The function inprod gives a W-invariant inner product for weights on this basis. @fundamental weight Fundamental weight For a chosen set of fundamental roots there is a basis of the weight lattice consisting of weights w1,..,wr such that = delta(i,j) for all i,j element {1 ,.., s}. These weights are called the fundamental weights. It is this basis on which weight vectors are expressed. @highest root Highest root This is the maximum of the set of roots with respect to the height partial ordering: lambda is higher than mu iff lambda-mu is a sum of positive roots. It is the highest weight of the adjoint representation. @levi subgroup Levi subgroup Any subset of the set of fundamental roots determines a closed subsystem (of which it is a basis fundamental roots) of the root system, and the fundamental Lie subgroup corresponding to this subsystem is called a Levi subgroup of g. The Dynkin diagrams of the Levi subgroups of g are therefore obtained by taking subsets of nodes of the diagram of g and retaining the edges between elements of the subset. @one parameter subgroup One parameter subgroup Any 1-dimensional subtorus h of T is called a one parameter subgroup, there is an algebraic group isomor- phism phi: C* -> h. Such one parameters subgroups may be represented in the following way, which is very similar to the representation of toral elements. For 1<= i <= r we have a group homomorphism z -> phi(z)^wi from C* to C* ; this homomorphism is equal to the map z ^ ai for some ai element Z. The one parameter subgroup h is now represented by the vector [a1,...,:ar, 0]. The final 0 serves to distinguish it from toral elements, which are valid in the same positions where one parameter subgroups may be used (e.g., as parameter to cent_roots). The integers a1 ... ar should not all have a non-trivial factor in common, because the morphism phi would then fail to be injective. Any toral element obtained by substituting some number n for the final zero lies in h (it is phi(zeta_n) where zeta_2 = exp(2*Pi*I/n). The restriction matrix of h is obtained by arranging the ai (for i = 1, 2, : :,:r) vertically into a one-column matrix. @positive root Positive root A root that can be expressed as a linear combination of fundamental roots with non-negative coefficients is called a positive root. For every root a exactly one of { a, -a} is positive. @root Root A non-zero weight for the adjoint representation of g is called a root of g. For each root the orthogonal reflection in the hyperplane perpendicular to it preserves the weight lattice. @root lattice Root lattice The sublattice of the weight lattice generated by the roots of g is called the root lattice. For semisimple groups the root lattice has finite index in the weight lattice, for simple groups of type An , Bn , Cn , Dn , En , F4 and G2 this index is n + 1, 2, 2, 4, 9 n, 1 and 1 respectively. The fundamental roots form a basis of the root lattice, and the elements of the root lattice are root vectors. See also weight. @root matrix Root matrix A root matrix is a matrix whose rows specify a set of roots, represented as root vectors. Root matrices may be used to denote subsystems of the root system of g. @root system Root system The set of all roots is called the root system of g. It is usually denoted by phi. @root vector Root vector When an element of the root lattice is represented by its coefficients on the basis consisting of the fundamental roots a1 ,..., as, the result is called a root vector. So a root vector has as size the semisimple rank of the group, and such a vector v = [v1 ,.., vs] is interpreted as the sum s = a1*v1+ ... +as*vs. @toral element Toral element To describe elements of T we can use the fundamental weights wi. Recall that weights are in fact mappings T->C* , and a weight can therefore be evaluated at an element t element T, the resulting value be written t^lambda, the set of fundamental weights form a complete set of coordinates in the sense that any element t element T in uniquely determined by the values t^wi for i = 1,...,r. Although LiE cannot represent arbitrary complex numbers, it can represent torus elements of finite order, i.e., elements for which all t^wi are roots of unity. To this end, a vector [a1 ,..., ar, n] in LiE may represent the element t for which t^wi = exp(2*Pi*I/n) = zeta_n^ai where zeta_n = exp(2*Pi*I/n) is a canonical n-th root of unity. See also one parameter subgroup. Since this is not the usual presentation of a toral element in a classical Lie group like GL(n, C) (namely by the diagonal entries occurring when the element is diagonalised), an example is given in Chapter 5 of how to transform from one presentation to another. @weight Weight A weight with respect to a torus T is an algebraic group morphism T->C* ; it describes a 1-dimensional representation of T. These arise in the decomposition of the restriction to T of repre- sentations of g, in which case they are called the weights of the g-representation with respect to T. The set Lambda(T) of weights is an Abelian group, where the group operation is pointwise multiplication of weights as C -valued functions (which corresponds to the tensor product of 1-dimensional T-representations), this is written additively. We consequently use the exponential notation t to indicate application of a weight to t element T, so that we have t^(lambda+mu)= t^lambda*t^mu. The fundamental weights span the weight lattice as a free Z-module; expressing a weight on this basis we obtain a so-called weight vector. @weight lattice Weight lattice The set Lambda(T) of all weights of g with respect to T is called the weight lattice. The addition defined for weights turns Lambda(T) into an Abelian group isomorphic to Z^r. @weight vector Weight vector When a vector is represented by its coefficients on the basis consisting of the fundamental weights w1 ,.., wr, it is called a weight vector. So a weight vector v = [v1 ,..,vs] is interpreted as the sum s = v1*w1+ ... + vs*ws. @bruhat descendent Bruhat descendent For any element w element W the Bruhat descendents are those elements x element W for which x < w in the Bruhat order and the length l(x) is exactly one less than l(w). Any element y element W with y <= w can be obtained starting from w by repeatedly moving from an element to one of its Bruhat descendents. @bruhat order Bruhat order The Bruhat order is a partial ordering defined on any Coxeter group. It can be determined by the following recursive defini- tion. For the identity element e element W we have x <= e <-> x = e. For any other element y element W there is some simple reflection ri such that l(yri) x0<=yri, where x0 is the element with the smaller length from {x, xri}. This definition is independent of the choice of ri. Incidentally, the definition implies that the condition l(yri). Every Weyl group is a Coxeter group, with Coxeter matrix given by mi,j= order(ri*rj). @coxeter matrix Coxeter matrix A Coxeter matrix is a symmetric matrix m = (m[i,j]) 1<=i,j<=s with positive integer entries, such that m[i,j]= 1 if and only if i = j. Such a matrix is used to define a Coxeter group. @distinguished coset representative Distinguished coset representative Within the Weyl group W we may consider left-, right-, and double cosets with respect to a sub- group (or in the case of double cosets, two subgroups) generated by fundamental reflections, in each case the unique element of small- est length in its coset is called the distinguished coset representative. Note that this term refers to a Weyl group element as representative for a coset, not to a Weyl word representing that Weyl group element. @dominant weight Dominant weight A weight whose inner products with all funda- mental roots are non-negative is called dominant. Equivalently, if the weight is written on the basis of the fundamental weights w1 ,..., wr, then the first s coefficients (corresponding to the semisimple part of the weight lattice Lambda(T)) are non-negative. @exponents Exponents e1 ,..., er The algebra of polynomial functions invariant under the action of the Weyl group of g in its standard reflection representa- tion is generated by r homogeneous polynomials of respective degrees e1 + 1, e2 + 1 ,..., er + 1. Usually the exponents of g are given in weakly increasing order. @kazhdan-Lusztig polynomial Kazhdan-Lusztig polynomial For any pair x, y of elements of a Cox- eter group W a polynomial Px,y is defined, called Kazhdan-Lusztig polynomial. Further information in manual. @lenght Length The length of a Weyl group element w is the smallest number l such that w is a product of l fundamental reflections. Hence, it is the size of a reduced Weyl word representing w. @longest element Longest element In every finite Coxeter group W there is a unique element of maximal length. It is an involution (but in general not a reflection), and is called the longest element of W . @orbit Orbit When a group W acts (from the right) on a set X, any x element X has an orbit,which is the set of all distinct values of x.w for w element W. @orbit matrix Orbit matrix When a finite group acts on any lattice by integral matrices, an orbit may be represented by an orbit matrix, each row of which represents one element of the orbit. @reduced weyl word Reduced Weyl word If an element w of the Weyl group is expressed as a product ri1 rim of fundamental reflections, and no product of fewer than m fundamental reflections yields w, then the sequence [i1, : :,:im ] is a reduced Weyl word for w. In general such a reduced Weyl word is not uniquely determined by w, but see canonical Weyl word. @reflection Reflection A Weyl group element that acts on the weight lattice, fix- ing a sublattice of rank r 1, is an orthogonal reflection in the hyper- plane perpendicular to some root. The reflections are precisely the conjugates of the simple reflections, and the latter description makes sense for arbitrary Coxeter groups. @r-polynomial R-polynomial For any pair x, y of elements of a Coxeter group W a polynomial R_x_y in one indeterminate is defined, called R-polynomial. These polynomials are related to the Kazhdan-Lusztig polynomials. @weyl group Weyl group The Weyl group W is defined as the quotient of the nor- maliser N_g(T) of the maximal torus T in g by the centraliser of T in g (which is T itself). W is a finite group, and has a faithful linear rep- resentation on the weight lattice Lambda(T). The elements of W are often identified with their images in this representation. The fundamental reflections r1 ,..., rs in this representation are canonical generators of W. @weyl word Weyl word An element of the Weyl group W may be presented as a product of the fundamental reflections ri (1<=i<=s). If ri_1,...,ri_l is such a product, the corresponding Weyl group element may be represented by the so-called Weyl word [ri_1 ,..., ri_l]. It is allowed to include entries equal to 0 in a Weyl word, which are ignored by LiE, no function that returns Weyl words will include such zeros in the result, except possibly as a padding at the right end when that Weyl word forms a row in a matrix of Weyl words of different lengths. @character polynomial Character polynomial (symmetric group). For the symmetric group on n letters, the conjugacy classes are parametrised by partitions of n, where the parts of the partition correspond to the disjoint cycles of the permutation. Therefore a character X_lambda of the symmetric group may be represented by a character polynomial, which is a polynomial in n indeterminates, in which each exponent represents a partition mu of n (padded with trailing zeros) and its coefficient is the (integral) value X_lambda(mu) of the character X_lambda on the conjugacy class corresponding to mu. @partition Partition A partition of a natural number n is a weakly decreasing sequence of numbers whose sum is n; adding or removing trailing zeros does not alter the partition. Any partition of n can be represented as a vector v = [v1 ,..., vn ] of length n. The LiE function partitions(n) produces a matrix whose rows represent the partitions of n. Partitions of n parametrise the conjugacy classes of the symmetric group on n letters and also their irreducible characters, they also parametrise dominant weights of SL_n or GL_n . @partition coordinates Partition coordinates A weight x for a group of type A_(n-1) can be expressed in partition coordinates by forming a vector of length n whose i-th entry is the sum of the coefficients in x of the j-th fun- damental weights for j >=i (note that the final entry is always 0). Conversely the coefficient of the i-th fundamental weight can be ob- tained as the difference between the i-th and the i + 1-st partition coordinate. In LiE these conversions can be performed by the func- tions to_part and from_part. Partition coordinates are used for the function LR_tensor. @robinson-schensted correspondence Robinson-Schensted correspondence The Robinson-Schensted cor- respondence is an algorithmically defined bijection between the el- ements of the Symmetric group Sn and the set of pairs of Young tableaux of equal shape with n entries. @shape Shape The shape of a Young tableau is a partition describing the length of the rows of the tableau. @symmetric group Symmetric group The set of permutations of {1,...,n} is called the Symmetric group on n letters, often denoted by S_n. Its conjugacy classes are described by partitions,|as well as its characters. @tableau Tableau A (Young) tableau is an arrangement of a set {1,2,...,n} of numbers into rows of weakly decreasing length,such that the num- bers increase along rows and columns.The shape of a tableau is the sequence of its row lengths,which is a partition. A typical example is 1 2 4 6 11 3 5 8 7 10 9 12 which has shape [5, 3, 2, 2]. In LiE, tableaux are represented linearly by vectors of size n. If t is such a vector, then t[i] indicates the row number of the entry i in the 2-dimensional form. For instance, the tableau above would be encoded as [1, 1, 2, 1, 2, 1, 3, 2, 4, 3, 1, 4]. A function print_tab is provided to display the 2-dimensional form of a tableau. Young tableaux have many applications in the theory of the symmetric group, for instance the number of tableaux of shape is equal to the dimension of the irreducible representation of S_n corre- sponding to . @adams operator Adams' operator For each n > 1 there is an operator, called the n-th Adams' operator, defined on the set of virtual g-modules, which has the effect on the characters of scaling each occurring weight by a factor n (while retaining its multiplicity). In general the result is a vir- tual module even if the original module was actual. The n-th Adams' operator is the `weight analog' of the operator that, given a character O of a finite group g, computes the decomposition of the class function gamma->X(gamma^n) as an integral linear combination of irreducible charac- ters. The operator is useful for computing symmetrised tensor powers. @adjoint representation Adjoint representation Each Lie group g acts on its Lie algebra by conjugation, which defines a representation of the group, the so-called adjoint representation. The non-zero weights of this representation (all of which occur with multiplicity 1) are called the roots of g. @alternating Weyl sum Alternating Weyl sum The Alternating Weyl has the interesting property that it gives the same result when applied to a decomposition polynomial as when applied to the corresponding character polynomial. Note that the expression above suggests an alternative action of W on polynomials, where the i-th generator of W (as a Coxeter group) does not act on exponents by reflection in the hyperplane perpendicular to ai, but rather in that plane shifted by wi (or equivalently by rho), and meanwhile also changes the sign of the coefficients. For this action J (p) is just the sum of the W - images of p. However, since this "shifted alternating action" plays no role except via the operator J , we will not introduce any further terminology or notation relating to it. @branching Branching Branching is another word for restricting a g-module M to another reductive group h. Suppose h is a closed reductive Lie subgroup of g. The branching problem concerns finding the decompo- sition into highest weight modules of M when viewed as an h-module. Since the maximal torus T_g of g is unique up to conjugacy, and sim- ilarly for h, the maximal torus T_h of h may be chosen within T_g. Consequently, each weight with respect to T_g determines by restric- tion a weight with respect to T_h, which defines a linear transformation Lambda(T_g)->Lambda(T_h). In fact we can define such a restiction transforma- tion in the more general setting of an arbitrary Lie group morphism f: h->g (not just for embeddings), consequently we can consider branching for such situations as well. The matrix m which describes this transformation on the respective bases of fundamental weights, is called the restriction matrix for h in g, and plays a crucial role in the function branch. The function res_mat helps to find the restriction matrix in cases where h is a fundamental Lie subgroup, LiE has also access to a table of precomputed restriction matrices for cases where h is a maximal subgroup in g but not a fundamental Lie subgroup. @character Character For a representation of a group on a finite dimensional vec- tor space we may define a function on the group by assigning to each group element the trace of the corresponding transformation of the vector space. This function, which is constant on conjugacy classes, is called the character of the representation. For reductive complex Lie groups the character determines the representation up to isomor- phism, and this is already true for the restriction of the character to the maximal torus T . Now the restriction to T of the representation decomposes into a direct sum of 1-dimensional representations, and the character of such a 1-dimensional representation is just a weight. Hence the restriction to T of the character of the whole representa- tion can be correspondingly written as a formal sum of weights (formal because we don't use the Abelian group structure of Lambda(T) here, but just count the occurring weights with multiplicities, in other words, the sum is taken in the group algebra of Lambda(T) ) and this is called the formal character of the representation. This character can be conve- niently encoded as a character polynomial. @character polynomial Character polynomial The (formal) character of a representation of g can be expressed as a polynomial, which records each weight w occurring with multiplicity m in the character as a term m*X^w of the polynomial. @contragredient representation Contragredient representation For each representation of g on a vector space V there is a corresponding representation, called its con- tragredient representation, on the dual vector space V^* . Here a group element a acts on an element f: V->C of V^* by mapping it to f.a: v->f (v.a^(-1)). As an example where the contragredient occurs, consider the space of homogeneous polynomial functions of degree n on V , this is a finite dimensional space on which g acts (by the same formula as above, but with for a polynomial function replacing f ). This representation of g is isomorphic to the n-th symmetric tensor power of the contragredient representation of the original representa- tion. @decomposition polynomial Decomposition polynomial The decomposition of a g-module M into irreducible modules may be represented by a decomposition poly- nomial d. Each term m*X^lambda of d represents a dominant weight such that the highest weight module V occurs in M with multiplicity m. In certain circumstances we allow m to be negative, in which case there is no module corresponding to d, but we may think of M as a formal sum (with integral scalar coefficients) of irreducible modules. In this case M is called a virtual module, and the polynomial a virtual decomposition polynomial. @demazure operator Demazure operator For each simple root ai a linear operator M_ai, called Demazure operator, is defined on the set of polynomials with exponents in Lambda(T). A discussion of the mathematical significance of this operator is beyond the scope of this manual, as it involves the representation theory of parabolic subgroups, which are not reductive. @dominant character polynomial Dominant character polynomial Since character polynomials are invariant under W , and each W-orbit of weights contains a unique dominant element, the information of a character polynomial can be more compactly represented by omitting all terms whose exponents are not dominant. The polynomial obtained in this way from the character polynomial of a g-module M is called the dominant charac- ter polynomial of M . LiE provides functions filter_dom and W_orbit for going from the character polynomial to the dominant character polynomial and back again. @highest weight Highest weight The maximum of the set of weights of some irre- ducible representation of g with respect to the partial ordering < is called the highest weight, it always exists and is a dominant weight that occurs with multiplicity 1. Conversely, every dominant weight lambda occurs as the highest weight of a unique irreducible representation V_lambda of g. By definition, lambda0GL(M ). As such it can be composed with any representation of the group GL(M ) on a vector space N , giv- ing rise to a representation of g on the space N . Now if we take for the representation of GL(M ) the irreducible one parametrised by the partition lambda (in partition coordinates), then the resulting representa- tion of g is called the plethysm, or symmetrised tensor power, of M with respect to lambda. @representation Representation An action by linear transformations of a group g on a finite dimensional vector space V (where the representing matrices depend in a polynomial way on the coordinates of the group element), is called a (rational) representation of the group, the space V is then called a module for g. This is equivalent to giving a (Lie) group mor- phism g -> GL(V ). The irreducible representations of finite groups, as well as of reductive Lie groups, are determined (up to equivalence) by their characters. For reductive Lie groups, the irreducible repre- sentations are parametrised by their highest weights. @restiction matrix Restriction matrix If h is a reductive subgroup of g, and a maximal torus of h is chosen within the maximal torus T of g, then any weight of g with respect to T (which is a function on T ) becomes by restriction to the maximal torus of h a weight of h. Consequently there is a map from the weight lattice of g to that of h, and this map is linear, it can therefore be given by a matrix, called the restriction matrix for the subgroup h. A similar matrix can be defined for an arbitrary Lie group morphism f : h->g. Each row of this matrix represents the restriction to the maximal torus of h of a fundamental weight of g, viewed as a weight of h. The restriction matrix plays a role in branching. @virtual module virtual module A formal sum of irreducible g-modules with inte- ger coefficients corresponds to an actual g-module only if all the co- efficients are non-negative (the module can then be constructed by @finish LiE/Makefile0000644000175000017500000000673707073311124012130 0ustar hakanhakansrcdir :=$(shell pwd) CFLAGS= -O fixed-flags = -I$(srcdir) -I$(srcdir)/box all-C-flags:= -ansi $(fixed-flags) $(CFLAGS) non-ansi-flags := $(fixed-flags) $(CFLAGS) CC = gcc # some compiler for ANSI/ISO C # These settings should also be used in subdirectories: export CC all-C-flags fixed-flags CFLAGS .SUFFIXES: %.o: %.c $(CC) -c $(CPPFLAGS) $(all-C-flags) $< common_objects=lexer.o parser.o\ non-ANSI.o bigint.o binmat.o creatop.o gettype.o getvalue.o\ init.o learn.o main.o mem.o node.o onoff.o output.o poly.o sym.o objects=$(common_objects) print.o getl.o GAP_objects=$(common_objects) gapprint.o gapgetl.o # Global organisation (phony targets) .PHONY: install all script finish no_readline .PHONY: math_functions binding_functions # The first target makes everything to get an operational LiE program install: all script INFO.a # To 'make all', we first descend into the subdirectories, and afterwards # return to finish here. all: $(MAKE) math_functions binding_functions $(MAKE) finish finish: Lie.exe LEARN.ind INFO.ind # do not call 'make finish' directly math_functions: $(MAKE) -C box all binding_functions: $(MAKE) -C static # Real dependencies # The file non-ANSI.c should be compiled without -ansi flag non-ANSI.o: non-ANSI.c $(CC) -c $(CPPFLAGS) $(non-ansi-flags) $< # These object files depend on the data types declared in those .h files: gettype.o getvalue.o init.o main.o mem.o node.o sym.o: memtype.h nodetype.h # The parser is generated by bison (BSD-yacc will NOT do) and in compilation # requires inclusion of parseaux.c (derived from parseaux.w). parser.c parser.h: parser.y bison -d --output-file=parser.c parser.y parser.o: parser.c parser.h parseaux.c lexer.o: parser.h # Binding to the GNU readline library is achieved by -Dpreprocessor below getl.o: getl.c $(CC) -c $(CPPFLAGS) -Dpreprocessor $(all-C-flags) $< gapgetl.o: getl.c $(CC) -c $(CPPFLAGS) $(all-C-flags) -o gapgetl.o $< # Though date.c never changes, it should be recompiled for each modifiaction. # Since Liegap is a separate executable, it gets its own version of the date. # Since global recompilation should be issued by 'make all' rather than by # 'make Lie.exe', we may assume here that the '.last_compiled' dates have just # been set to the most recent one of object files in the respective # subdirectories, whence taking that dummy file as dependency suffices. date.o: date.c $(objects) box/.last_compiled static/.last_compiled $(CC) -ansi -c date.c gapdate.o: date.c $(GAP_objects) box/.last_compiled static/.last_compiled $(CC) -ansi -c -o gapdate.o date.c Lie.exe: date.o $(CC) -o Lie.exe $(objects) date.o static/*.o box/*.o -lreadline chmod g+w Lie.exe Liegap.exe: gapdate.o $(CC) -o Liegap.exe $(GAP_objects) gapdate.o static/*.o box/*.o chmod g+w Liegap.exe noreadline: math_functions binding_functions $(common_objects) print.o $(CC) -c $(CPPFLAGS) $(all-C-flags) getl.c $(MAKE) date.o $(CC) -o Lie.exe $(objects) date.o static/*.o box/*.o chmod g+w Lie.exe $(MAKE) LEARN.ind INFO.ind script INFO.a script: ./make_lie INFO.ind: INFO.0 INFO.1 INFO.2 INFO.3 INFO.4 infoind ./infoind LEARN.ind: LEARN learnind ./learnind infoind: util/infoind.c $(MAKE) -C util ../infoind learnind: util/learnind.c $(MAKE) -C util ../learnind INFO.a: progs/maxsub progs/maxsub0 progs/eqrank rm -f INFO.a ./Lie.exe < progs/maxsub .PHONY: clean clean: $(MAKE) -C box clean $(MAKE) -C static clean rm -f *~ *.o parser.[ch] INFO.a LEARN.ind rm -f Lie.exe Liegap.exe infoind learnind util/*.o LiE/README0000600000175000017500000000570307073323262011336 0ustar hakanhakanThis file is part of the distribution of the software package LiE. It applies to the compile-only version of LiE; if you should wish to read the source files, you are advised to obtain the documented version instead. The program LiE is a stand-alone application. One does need the GNU parser generator program 'bison' to install it (in principle the standard UNIX tool 'yacc' should also work, but Berkeley yacc will produce code that does not compile; Linux users take note). LiE is also configured to make use of the GNU command line preprocessor 'readline' if it is installed as a library on our system. The compliation process is to be controlled by GNU 'make'. If you have the GNU C-compiler gcc, then there should be no need to alter the Makefile provided with LiE. If you do not, you can substitute the name of another compiler after 'CC =' in the makefile, and check that the flags specified (notably -ansi for strict ANSI/ISO C compilation) follow the option syntax of that compiler; you may also to specify some additional options. Having done this, type `make' and sit back; hopefully everything now works automatically. What happens is that first all source files for LiE are compiled, and linked to the executable file `Lie.exe'; two small indexing programs `infoind' and `learnind' are also compiled. Then the indexing programs are run to create index files for the help system. Finally `Lie.exe' is invoked to run a script (progs/maxsub) which does some computations and then writes a small data base file (INFO.a) that can be accessed by some of LiE's functions. When this all succeeds, one has a fully functional version of LiE, that can be called as `lie' if the file of that name (a small shell script created during the build process) can be found in the search path for commands (you may need to move it to a suitable directory, where it will still find the necessary files from LiE). If you do not have the GNU readline library on your system, you may experience problems during the linking of the executable file Lie.exe. In that case you can say 'make noreadline' instead of 'make', and it should produce a version without command line preprocessing. There is also a special version of LiE that is modified to be callable from the GAP package; it has a slightly modified output routine and no command line preprocessor. To build it, say `make Liegap.exe', and an executable file of that name will be built. To use it from GAP, you will need the two GAP source files in the `gapfiles' subdirectory. You can move these to a place where GAP can find them, and edit the line starting with `EXEC' near the end of `liegap.g' such that the `cd LiE' command makes the correct directory change to the LiE source directory. Then you can call any LiE function from GAP by prefixing its name with "Lie", for instance `LieCartan' or `Lietensor'; you may study the function definitions in `lie.g' for the interface conventions used by GAP. Last modified April 2000 Marc van Leeuwen, Poitiers LiE/ansi.h0000664000175000017500000001774107120144436011575 0ustar hakanhakan/* bigint.c */ bigint* normalize(bigint* a); /* return a=normal(a) */ bigint* entry2bigint(entry n); entry bigint2entry(bigint* num); int cmp1(bigint* a, digit n); int cmp(bigint* a, bigint* b); bigint* mul1add(bigint* b, digit n, digit m); /* return b=b*n+m */ digit div1(bigint* b,digit n); /* b/=n; return b%n */ bigint* mult(bigint* a, bigint* b); bigint* divq(bigint* a, bigint* b); /* a%=b; return a/b */ bigint* quotient(bigint* a, bigint* b); bigint* mod(bigint* a, bigint* b); bigint* str2bigint(string s); string bigint2str(bigint* num); int printbigint(bigint* num, int len); bigint* norm(bigint* z); bigint* add(bigint* a, bigint* b); bigint* sub(bigint* a, bigint* b); object power(object a, bigint* b, object unit, f2object f); void addc(bigint** a, digit b); void mulc(bigint** a, digit b); void divc(bigint** a, digit b); /* binmat.c */ void Objectwrite(object m, group* g, char *t); void Objectsave(object m, char *t); object Objectread(group* g, char *t); object Objectget(char *t); /* creatop.c */ symblst creatopsym(int n, strtype a, fobject f, int restype, ...); /* date.c */ extern char date[]; /* learn.c */ boolean substring(char* key, char* name); void build_directory(learn_index_tp* learn, long nitems); boolean Learn(char* name); entry exec_learn(char* name); /* mapleread.c */ void maple_read(char* fname); /* onoff.c */ void mark_defaultgrp_stack(void); boolean set_on(entry num, strtype name); boolean set_off(entry num, strtype name); void save_state(void); void restore_state(void); void init_state(void); void print_state(void); void unmark_sorted(void); cmp_tp height_incr(entry* v, entry* w, index len); cmp_tp height_decr(entry* v, entry* w, index len); /* output.c */ void monitor_cmd(char* file_arg); void endmon(void); void invoke_prog(char* prog, char* args); boolean enter_input_file(char* fname); boolean exit_input_file(boolean parse_error); void print_runtime(void); void registrate_cpu(void); #ifdef __GNUC__ void error(char* format, ...) __attribute__ ((noreturn)) __attribute__ ((format (printf,1,2))); void fatal(char* format, ...) __attribute__ ((noreturn)) __attribute__ ((format (printf,1,2))); void share_error(object o) __attribute__ ((noreturn)); int Printf(char* format, ...) __attribute__ ((format (printf,1,2))); void err_Printf(char* format, ...) __attribute__ ((format (printf,1,2))); void monprintf(char* format, ...) __attribute__ ((format (printf,1,2))); #else void error(char* format, ...); void fatal(char* format, ...); void share_error(object o); int Printf(char* format, ...); void err_Printf(char* format, ...); void monprintf(char* format, ...); #endif /* par.c */ void initpar(void); /* print.c */ extern par_tp info_depth; void print_vector(vector* v); void print_matrix(matrix* m); void print_poly(poly* p); void print_mat_bars(matrix* m); void print_poly_vertical(poly* p); char* grp2str(group* grp); int printgrp(object obj); void printexpr(char* c, boolean pr, boolean doc); boolean opname_test(char* name); void writexpr(symblst s, short level); void printint(object obj); void printvec(object obj); void printtekst(object obj); void printgroup(object obj); void printlst(symblst topsym); boolean is_operator(char* aname); int Printc(char* c); void listops(symblst topsym, char* filename, boolean pr); void listvars(symblst topsym, char* filename); void listfuns(symblst topsym, char* filename); /* poly.c */ poly* Add_pol_pol(poly* a, poly* b, int sign); poly* Pol_from_vec(vector* v); poly* Addmul_pol_pol_bin(poly* a, poly* b, bigint* c); entry Degree_pol(poly* p); entry Degree1_pol(poly* p); poly* check_pol(poly* p, entry r); poly* Mul_bin_pol(bigint* a, poly* b); poly* Mul_pol_int(poly* a, intcel* b); poly* Mul_pol_pol(poly* a, poly* b); poly* Div_pol_bin(poly* a, bigint* b); poly* Div_pol_vec(poly* a, vector* b); poly* Mod_pol_bin(poly* a, bigint* b); poly* Mod_pol_vec(poly* a, vector* b); poly* Disjunct_mul_pol_pol(poly* p1, poly* p2); /* box/altdom.c */ poly* Alt_dom(poly* p); poly* Alt_dom_w(poly* p,vector* word); poly* Demazure(poly* p,vector* word); /* box/branch.c */ poly* Spectrum(poly* lambda, vector* toral_elm); poly* Branch_irr(entry* lambda, entry** m, object G); poly* Branch(poly* p, entry** m, object G); poly* Collect(poly* p, matrix* iresmat, entry d, object g); /* box/centr.c */ index isolcomp(matrix* ma, index i); matrix* Centroots(matrix* mm); object Centrtype(matrix* h); /* box/closure.c */ matrix* Closure(matrix* m, boolean close, group* lietyp); group* Carttype(matrix* ma); matrix* Resmat(matrix* m); /* box/contragr.c */ vector* Contragr(vector* g, object grp); poly* Contragr_p(poly* p, object grp); #include "coxeter.h" #include "decomp.h" /* box/defs.c */ void add_user_defined(void); /* box/diagram.c */ object Diagram(object grp); #include "domchar.h" /* box/factor.c */ object Factor(bigint* num); /* static5.c */ #include "grpdata.h" /* box/lr.c */ vector* To_Part_v(entry* wt,index l); matrix* To_Part_m(entry** wts,index n,index l); poly* To_Part_p(poly* p); vector* From_Part_v(entry* wt,index l); matrix* From_Part_m(entry** wts,index n,index l); poly* From_Part_p(poly* p); poly* LR_tensor_irr(entry* lambda, entry* mu, index n); poly* LR_tensor(poly* p,poly* q); /* box/matrix.c */ void copyrow(entry* v,entry* w,index n); /* ubiquitous, as are following: */ boolean eqrow(entry* v,entry* w,index n); void add_xrow_to(entry* v,entry f,entry* w,index n); void addrow(entry* v,entry* w,entry* x,index n); void subrow(entry* v,entry* w,entry* x,index n); boolean pos_subrow(entry* v,entry* w,entry* x,index n); entry inprow(entry* v,entry* w,index n); matrix* Transpose(matrix* m); /* static1.c */ void mulmatmatelm(entry** a,entry** b,entry** c,index l,index m,index n); void mulvecmatelm(entry* v,entry** b,entry* w,index m,index n); void mulmatvecelm(entry** a,entry* v,entry* w,index m,index n); matrix* Matmult(matrix* a, matrix* b); matrix* extendmat(matrix* old); matrix* copymatrix(matrix* old); matrix* Blockmat(matrix* a,matrix* b); void printarr(entry* a,index r); /* norm.c */ /* box/orbit.c */ matrix* Orbit(index limit, vector* v, entry** m, index n); #include "plethysm.h" /* box/sorting.w */ cmp_tp lex_incr(entry* v, entry* w, index len); cmp_tp lex_decr(entry* v, entry* w, index len); cmp_tp deg_incr(entry* v, entry* w, index len); cmp_tp deg_decr(entry* v, entry* w, index len); cmpfn_tp set_ordering(cmpfn_tp cmp, index n, object g); void swap(entry* x,entry* y); void sortrow(entry* a, index n); void swap_rows(entry** x,entry** y); /* centr.c */ void swap_terms(entry** w, bigint** coef, index i, index j); /* altdom.c */ void Qksortmat(matrix* m, cmpfn_tp criterion); matrix* Unique(matrix* m, cmpfn_tp criterion); poly* Reduce_pol(poly* p); index searchterm(poly* p, entry* t); /* altdom.c, decomp.c */ #include "symg.h" #include "tensor.h" /* box/weyl.c */ void simp_w_refl(entry* w,index i,simpgrp* g); /* dominant.c */ void w_refl(entry* almbda, index wi); void Waction(entry* lambda, vector* word); void Wrtaction(entry* root, vector* word); matrix* simp_Weylmat(vector* w, simpgrp* g); /* weyl.c, weylloop.c */ matrix* Weyl_mat(vector* w); matrix* Weyl_rt_mat(vector* w); bigint* Worder(object grp); bigint* sub_Worder(vector* v); bigint* Orbitsize(entry* w); matrix* Weyl_orbit(entry* v, matrix** orbit_graph); matrix* Weyl_root_orbit(entry* v); poly* Worbit_p(poly* p); poly* alt_Wsum(poly* p); #include "weylloop.h" /* static/static1.c */ matrix* mat_null(entry r,entry c); matrix* mat_id(entry size); object mat_add_mat_vec(object m, object v); object mat_add_mat_mat(object m, object v); object vec_add_vec_vec(object m, object v); /* static/static2.c */ object vec_addelm_vec_int(object v, object i); /* box/static3.c */ void testdom(entry* v,object grp); object int_eq_grp_grp(object g,object h); /* used in decomp */ /* static/static4.c */ object vid_print(object o); object inside_vid_assign(symblst list,boolean glob,fobject update); /* static/static5.c */ /* static/static6.c */ /* static/static7.c */ #undef digit #undef objtype LiE/bigint.c0000664000175000017500000002776307072415726012130 0ustar hakanhakan/* big integer arithmetic is done in base |2^15|, so that two digits can be safely added to give another |digit| */ #define SHIFT 15 #define MASK (digit)MaxDigit /* * bigint *entry2bigint(entry n) * entry bigint2entry(bigint *num) * int cmp1(bigint* a; digit n) * int cmp(bigint* a,bigint* b) * bigint *mul1add(bigint* b; digit n, m) * digit div1(bigint* b; digit n) * bigint *mult(bigint* a,bigint* b) * bigint *divq(bigint* a,bigint* b) * bigint *norm(bigint* z) * bigint *add(bigint* a,bigint* b) * bigint *sub(bigint* a,bigint* b) * bigint *power(object a,bigint* b, object unit, f2object f) */ #include "lie.h" #ifdef __STDC__ static bigint* x_add(bigint* a,bigint* b); static bigint* x_sub(bigint* a,bigint* b); static void errorc(void); #endif /* free argument pair a,b, but retain either if equal to z */ static void freepair(bigint* a,bigint* b,bigint* z) { #ifndef argumentsave if (a==b) { if (a!=z) freemem(a); } /* avoid freeing twice if a==b */ else { if (a!=z) freemem(a); if (b!=z) freemem(b); } #endif } bigint *normalize(bigint *a) { int size = abs(a->size); digit *d = a->data + size - 1; while (size > 0 && *d-- == 0) size--; a->size = (a->size < 0) ? -size : size; return a; } bigint *entry2bigint(entry n) { twodigits m; bigint *result; if (n == 0) return mkbigint(0); result = mkbigint(3); if (n < 0) { result->size = -3; m = -n; } else m = n; result->data[0] = m & MASK; m >>= SHIFT; result->data[1] = m & MASK; result->data[2] = m >> SHIFT; return normalize(result); } entry bigint2entry(bigint *num) { int size = abs(num->size); twodigits result = 0; digit *d = num->data + size - 1; if (size > 3 || size == 3 && *d > 1) error("Integer too big\n"); for (; size > 0; size--) result = (result << SHIFT) + *d--; return (num->size < 0) ? -(entry)result : (entry)result; } int cmp1(bigint* a,digit n) { int m = a->size; if (m < 0) return -1; if (m > 1) return 1; if (m > 0) m = *a->data; return (m < n) ? -1 : m != n; } int cmp(bigint* a, bigint* b) { int a_size = a->size, size; digit *d, *e; if (a_size < b->size) return -1; if (a_size > b->size) return 1; size = abs(a_size); d = &a->data[size]; e = &b->data[size]; for (; size > 0; --size) if (*--d != *--e) break; if (size == 0) return 0; return (a_size > 0) == (*d < *e) ? -1 : 1; } bigint *mul1add(bigint* b,digit n,digit m) { /* Side effect b */ int i, size = abs(b->size); digit *d; twodigits n2 = n, t = m; d = b->data; for (i = size; i > 0; i--) { t += n2 * *d; *d++ = t & MASK; t >>= SHIFT; } if (t) { if (b->allocsize == size) { b = extendbigint(b); d = b->data + size; } *d = t; b->size += (b->size < 0) ? -1 : 1; } return b; } digit div1(bigint* b,digit n)/* Side effect in b */ { digit* d; twodigits t = 0; int size = abs(b->size); if (size == 0) return (digit)0; d = b->data + size - 1; for (; size > 0; size--) { t = (t << SHIFT) + *d; *d-- = t / n; t %= n; } (void)normalize(b); return (digit)t; } bigint *mult(bigint *a, bigint* b) /* No side effect in a */ { int i, size_a = abs(a->size), size_b = abs(b->size); bigint *prod; if (size_a == 0 || size_b == 0) { freepair(a,b,NULL); return null; } prod = mkbigint(size_a + size_b); for (i = 0; i < prod->size; i++) prod->data[i] = 0; for (i = 0; i < size_a; i++) { twodigits carry = 0, f = a->data[i]; int j; digit *d = prod->data + i; for (j = 0; j < size_b; j++) { carry += *d + b->data[j] * f; *d++ = carry & MASK; carry >>= SHIFT; } while (carry) { carry += *d; *d++ = carry & MASK; carry >>= SHIFT; } } if ((a->size < 0) != (b->size < 0)) prod->size = -prod->size; freepair(a,b,NULL); return normalize(prod); } bigint *divq(bigint *a,bigint *b) /* Side effect in a */ /* result = a/b and a = a % b */ { int size_a = abs(a->size), size_b = abs(b->size); bigint *a_org = a, *quo; digit bl, d; int j, k; if (size_b == 0) error("Division by zero\n"); if (size_a < size_b || size_a == size_b && a->data[size_a-1] < b->data[size_b-1]) return null; if (size_b == 1) { entry rem = (entry)div1(a, *b->data); if (a->size < 0) rem = -rem; quo = copybigint(a, (bigint *)NULL); a = entry2bigint(rem); (void)copybigint(a, a_org); freemem( a); if (b->size < 0) quo->size = -quo->size; return quo; } d = (twodigits)(MASK + 1) / (b->data[size_b-1] + 1); a = copybigint(a, mkbigint(size_a+1)); (void)mul1(a, d); (void)mul1(b, d); /* size effect on b will be undone */ size_a = abs(a->size); bl = b->data[size_b-1]; quo = mkbigint(size_a - size_b + 1); for (j = size_a, k = size_a - size_b; k >= 0; j--, k--) { digit aj = (j >= size_a) ? 0 : a->data[j]; twodigits aj2 = ((twodigits)aj << SHIFT) + a->data[j-1], q; entry carry = 0L; int i; q = (aj == bl) ? MASK : aj2/bl; while (b->data[size_b-2] * q > ((aj2 - q * bl) << SHIFT) + a->data[j-2]) q--; for (i = 0; i < size_b && i+k < size_a; i++) { twodigits z = b->data[i] * q; carry += a->data[i+k] - (z & MASK); a->data[i+k] = carry & MASK; carry = (carry >> SHIFT) - (z >> SHIFT); } if (i+k < size_a) { carry += a->data[i+k]; a->data[i+k] = 0; } if (carry == 0) quo->data[k] = q; else { quo->data[k] = q-1; for (carry = i = 0; i < size_b && i+k < size_a; i++) { carry += a->data[i+k] + b->data[i]; a->data[i+k] = carry & MASK; carry >>= SHIFT; } } } if ((a->size < 0) != (b->size < 0)) quo->size = -quo->size; (void)normalize(a); (void)div1(a, d); copybigint(a,a_org); (void)div1(b, d); /* restore */ return normalize(quo); } bigint *quotient(a,b) bigint *a, *b; { bigint *result = divq( isshared(a)?(a=copybigint(a,NULL)):a , b); freepair(a,b,result); return result; } bigint *mod(a, b) bigint *a, *b; { int size_b = b->size; bigint *result = (isshared(a)?copybigint(a,NULL):a); bigint *garbage; if (size_b <= 0) error("Remainder should be modulo positive number.\n"); garbage = divq(result,b); #ifndef argumentsave freemem(garbage); #endif if (result->size < 0) { /* Result mod always has to be positive */ setshared(b); result = add(result,b); clrshared(b); } #ifndef argumentsave freemem(b); /* a is either shared or ==result */ #endif return(result); } /* convert string of digits to bigint; used in scanner */ bigint *str2bigint(string s) { bigint* result = mkbigint(2 + strlen(s)/4); int i; for (i=0, result->size=0; s[i]!='\0'; ++i) result = mul1add(result, 10, s[i]-'0'); return result; } string bigint2str(bigint* num) /* free result with |freem| */ { int i,n; unsigned long strsize = 4 + 5 * (unsigned long)abs(num->size); bigint *copynum = copybigint(num,(bigint *)NULL); string result = allocmem(strsize), s=result+strsize, t=result; *--s = '\0'; while (copynum->size) { n=div1(copynum,10000); for (i=4; i>0; i--,n/=10) *--s = n%10+'0'; } while (*s=='0') s++; /* skip leading 0's */ if (*s=='\0') *--s = '0'; /* but restore 0 if last remaining digit */ if (num->size<0) *--s = '-'; while ((*t++ = *s++)!=0) {} /* adjust to the left */ freemem(copynum); return result; } int printbigint(num,len) bigint *num;int len; { Short i; int nc = 0; string s = bigint2str(num); len = len-strlen(s); for (i=0;isize); int i= j; while (i > 0 && z->data[i-1] == 0) --i; if (i != j) z->size= (z->size < 0) ? -i : i; return z; } static bigint* x_add(a,b) bigint* a,* b; { /* No side effect, result address equal to first argument */ int size_a= abs(a->size), size_b= abs(b->size); bigint *z; int i; digit carry= 0; /* Ensure a is the larger of the two: */ if (size_a < size_b) { { bigint *temp= a; a= b; b= temp; } { int size_temp= size_a; size_a= size_b; size_b= size_temp; } } if (isshared(a) || (a->allocsize <= size_a)) z= mkbigint(size_a+1); /************************************************************* * Side effect on argument a * *************************************************************/ else { #ifdef development if (a==one) abort(); if (a==null) abort(); #endif z = a; z->size = size_a + 1; } for (i= 0; i < size_b; ++i) { carry += a->data[i] + b->data[i]; z->data[i]= carry & MASK; /* The following assumes unsigned shifts don't propagate the sign bit. */ carry >>= SHIFT; } for (; i < size_a; ++i) { carry += a->data[i]; z->data[i]= carry & MASK; carry >>= SHIFT; } z->data[i]= carry; return norm(z); } /* Subtract the absolute values of two integers. */ static bigint* x_sub(a, b) bigint *a, *b; { int size_a= abs(a->size), size_b= abs(b->size); bigint *z; int i; int sign= 1; digit borrow= 0; /* Ensure a is the larger of the two: */ if (size_a < size_b) { sign= -1; { bigint *temp= a; a= b; b= temp; } { int size_temp= size_a; size_a= size_b; size_b= size_temp; } } else if (size_a == size_b) { /* Find highest digit where a and b differ: */ i= size_a-1; while (i >= 0 && a->data[i] == b->data[i]) --i; if (i < 0) return mkbigint(0); if (a->data[i] < b->data[i]) { sign= -1; { bigint *temp= a; a= b; b= temp; } } size_a= size_b= i+1; } z= mkbigint(size_a); for (i= 0; i < size_b; ++i) { /* The following assumes unsigned arithmetic works modulo 2^N for some N>SHIFT. */ borrow= a->data[i] - b->data[i] - borrow; z->data[i]= borrow & MASK; borrow >>= SHIFT; borrow &= 1; /* Keep only one sign bit */ } for (; i < size_a; ++i) { borrow= a->data[i] - borrow; z->data[i]= borrow & MASK; borrow >>= SHIFT; } z->size *= sign; return norm(z); } /* Add two long integers, taking their signs into account. */ bigint* add(a, b) bigint* a,* b; { /* Result address equal to adress first argument */ bigint *z; if (a->size < 0) { if (b->size < 0) { z= x_add(a, b); z->size= -z->size; } else z= x_sub(b, a); } else if (b->size < 0) z= x_sub(a, b); else z= x_add(a, b); freepair(a,b,z); return z; } /* Subtract two long integers, taking their signs into account. */ bigint* sub(a, b) bigint* a,* b; { bigint *z; if (a->size < 0) { if (b->size < 0) z= x_sub(a, b); else z= x_add(a, b); z->size= -z->size; } else if (b->size < 0) z= x_add(a, b); else z= x_sub(a, b); freepair(a,b,z); return z; } /* Compute $f(\cdot,a)^{|b|}(unit)$ by a form of Chinese powering, assuming $f$ is an associative operation */ object power(object a, bigint* b, object unit, f2object f) { int size_b= abs(b->size); object z = unit; int i; for (i= 0; i < size_b; ++i) /* for digits from least to most significant */ { digit bi= b->data[i]; int j; for (j= 0; j < SHIFT; ++j) /* and for all bits of digit in same order */ { setshared(a); if ((bi&1)!=0) z=f(z,a); /* include $a^{2^{SHIFT*i+j}}$ into |z| */ bi >>= 1; if (bi == 0 && i+1 == size_b) break; /* avoid excess powering of |a| */ { object temp= f(a,a); clrshared(a); freemem(a); a= temp; }/* $a=a^2$ */ } } return z; } /*************************************************************** * Operations with type digit constants on bigints * ***************************************************************/ /* subc is not defined */ /* addc, mulc, divc, modc */ static void errorc() { error("System: Pointer to bigint is NULL.\n"); } #ifdef __STDC__ void addc(bigint** b,digit n) #else void addc(b,n) bigint **b; digit n; #endif { if (!(*b)) errorc(); if (isshared(*b)) *b = copybigint(*b,NULL); *b = mul1add(*b,1,n); } #ifdef __STDC__ void mulc(bigint** b,digit m) #else void mulc(b,m) bigint **b; digit m; #endif { if (!(*b)) errorc(); if (isshared(*b)) *b = copybigint(*b,(bigint*) NULL); *b = mul1add(*b,m,0); } #ifdef __STDC__ void divc(bigint** b,digit n) #else void divc(b,n) bigint **b; digit n; #endif { if (!(*b)) errorc(); if (isshared(*b)) *b = copybigint(*b,(bigint*) NULL); div1(*b,n); } LiE/binmat.c0000644000175000017500000000775606760533277012131 0ustar hakanhakan#include "lie.h" /* Is concerned with storing and restoring binary matrices */ #define SUFFIX ".a" typedef struct { unsigned long size; char name[KEYWORDLEN], dirname[KEYWORDLEN]; } header_type; static matrix *read_format_mat(matrix* store) { entry **ptr; entry *elm; boolean okay = (type_of(store) == MATRIX); int r = store->nrows, c = store->ncols; if (!okay) error("File has not the right (matrix) format.\n"); store->elm = ptr = (entry**) (store + 1); elm = (entry *) (ptr + r); for (; r; r--, ptr++, elm += c) *ptr = elm; return copymatrix(store); } static tekst *read_format_string(tekst *store) { boolean okay = (type_of(store) == TEKST); if (!okay) error("File has not the right (string) format.\n"); store->string = (char*) (store + 1); return copytekst(store); } static void error_file(char* task,char* filename) { error("Error %s file %s.\n",task,filename); } static unsigned long matlen(unsigned long lr,unsigned long lc) { return sizeof(matrix) + (lr?lr:1L) * sizeof(entry*) + lr * lc * sizeof(entry) + (lr?lr:1L) * sizeof(bigint*); } static header_type *pack_object (object m,char* dirname, char* name, unsigned long* size) { unsigned long n = type_of(m) == MATRIX? matlen((unsigned long) m->m.nrows, m->m.ncols): sizeof(tekst) + m->t.len + 1; header_type* result = (header_type*)malloc(sizeof(header_type)+n); memcpy(&result[1],m, n); /* copy |m| after header */ result->size = n; strcpy(result->dirname,dirname); strcpy(result->name,name); *size = n; return result; } void Objectwrite(object m,group* g,char* t) { unsigned long size; char* s=grp2str(g); header_type *store = pack_object(m,s,t,&size); FILE *fp; char filename[LABELLENGTH]; strcpy(filename,infofil); strcat(filename,SUFFIX); fp = fopen(filename,"a"); if (fp==NULL) error_file("opening",filename); if (fwrite(store, size+sizeof(header_type), 1, fp)==0) error_file("writing",filename); fclose(fp); freem(s); free(store); } object Objectread(group *g, char* name) { object result,store; header_type header; char* dirname = grp2str(g); char filename[LABELLENGTH]; FILE *fp; strcpy(filename, infofil); strcat(filename,SUFFIX); fp = fopen(filename,"r"); if (fp==NULL) error_file("opening",filename); do /* search name and dirname */ { if (fread(&header, sizeof(header_type), 1 ,fp)==0) if (feof(fp)) { fclose(fp); return (object) NULL;} else error_file("reading",filename); if (strcmp(header.name,name)==0 && strcmp(header.dirname,dirname)==0) break; if (fseek(fp,header.size,SEEK_CUR)!=0) /* advance past item */ error("Failed to find %s/%s in file %s.\n",dirname,name,filename); } while (true); store = (object) safe_alloc(header.size); if (fread((char*) store, 1, header.size, fp)==0) error_file("reading",filename); result = (type_of(store)== MATRIX) ? (object) read_format_mat((matrix*) store): (object) read_format_string((tekst*) store); freem(dirname); free(store); fclose(fp); return result; } void Objectsave(object m, char* t) { unsigned long size; header_type *store = pack_object( m, "",t,&size); FILE *fp; fp = fopen(t,"w"); if (fp==NULL) error_file("opening",t); if (fwrite(store, size+sizeof(header_type), 1, fp)==0) error_file("writing",t); fclose(fp); free(store); } object Objectget(char* name) { object result,store; header_type header; FILE *fp; fp = fopen(name,"r"); if (fp==NULL) error_file("opening",name); if (fread(&header, sizeof(header_type), 1 ,fp)==0) error_file("reading header of",name); if ((store = (object) malloc(header.size))==NULL) error("No memory available"); if (fread((char*) store, 1, header.size, fp)==0) error_file("reading",name); result = (type_of(store)== MATRIX) ? (object) read_format_mat((matrix*) store): (object)read_format_string((tekst*) store); free(store); fclose(fp); return result; } LiE/creatop.c0000664000175000017500000000134607075111656012274 0ustar hakanhakan#include "lie.h" static symblst creatop(strtype a,fobject f,objtype restype) { symblst s; s = creatsym(a); s->class = OPERATOR; s->type = restype; s->data.f = f; return (s); } static symblst mkarg(int n) /* arguments allocated outside reach of GC */ { if (n == 0) return NULL; return alloc_array(symbrec,n); } symblst creatopsym (int n, strtype a, fobject f, int restype, ...) { va_list ap; int i, argtype; symblst t, s; va_start(ap, restype); s = creatop(a, f, restype); s->arglst = t = mkarg(n); for (i = 0; i < n; ++i) { t->class = DUMMY; t->a.name = 0; argtype = va_arg(ap, int); t->type = (objtype) argtype; t= t->next = (i==n-1 ? NULL : t + 1); } va_end(ap); return s; } LiE/date.c0000664000175000017500000000005006211554373011541 0ustar hakanhakanchar date[] = __DATE__ " at " __TIME__; LiE/gapfiles/0002775000175000017500000000000007251120423012247 5ustar hakanhakanLiE/gapfiles/lie.g0000644000175000017500000013054306217536054013206 0ustar hakanhakan############################################################################# ## #F LieAdams . . . . . . . . . . . . . . . . . call the LiE function "Adams" ## LieAdams := function( arg ) local res; if Length(arg) = 3 and IsLieGroup(arg[1]) and IsInt(arg[2]) and IsVector(arg[3]) then # return type: POLY res := CallLie("Adams", arg[2], arg[3], arg[1]); elif Length(arg) = 3 and IsLieGroup(arg[1]) and IsInt(arg[2]) and IsLiePoly(arg[3]) then # return type: POLY res := CallLie("Adams", arg[2], arg[3], arg[1]); else Error( "LiE has no function \"Adams\" for these types" ); fi; return res; end; ############################################################################# ## #F LieBruhat_desc . . . . . . . . . . . call the LiE function "Bruhat_desc" ## LieBruhat_desc := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: MATRIX res := CallLie("Bruhat_desc", arg[2], arg[1]); elif Length(arg) = 3 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsVector(arg[3]) then # return type: MATRIX res := CallLie("Bruhat_desc", arg[2], arg[3], arg[1]); else Error( "LiE has no function \"Bruhat_desc\" for these types" ); fi; return res; end; ############################################################################# ## #F LieBruhat_leq . . . . . . . . . . . . call the LiE function "Bruhat_leq" ## LieBruhat_leq := function( arg ) local res; if Length(arg) = 3 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsVector(arg[3]) then # return type: INTEGER res := CallLie("Bruhat_leq", arg[2], arg[3], arg[1]); else Error( "LiE has no function \"Bruhat_leq\" for these types" ); fi; return res; end; ############################################################################# ## #F LieCartan . . . . . . . . . . . . . . . . call the LiE function "Cartan" ## LieCartan := function( arg ) local res; if Length(arg) = 3 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsVector(arg[3]) then # return type: INTEGER res := CallLie("Cartan", arg[2], arg[3], arg[1]); elif Length(arg) = 1 and IsLieGroup(arg[1]) then # return type: MATRIX res := CallLie("Cartan", arg[1]); else Error( "LiE has no function \"Cartan\" for these types" ); fi; return res; end; ############################################################################# ## #F LieCartan_type . . . . . . . . . . . call the LiE function "Cartan_type" ## LieCartan_type := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsMatrix(arg[2]) then # return type: GROUP res := CallLie("Cartan_type", arg[2], arg[1]); else Error( "LiE has no function \"Cartan_type\" for these types" ); fi; return res; end; ############################################################################# ## #F LieDemazure . . . . . . . . . . . . . . call the LiE function "Demazure" ## LieDemazure := function( arg ) local res; if Length(arg) = 3 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) and IsVector(arg[3]) then # return type: POLY res := CallLie("Demazure", arg[2], arg[3], arg[1]); elif Length(arg) = 3 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsVector(arg[3]) then # return type: POLY res := CallLie("Demazure", arg[2], arg[3], arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) then # return type: POLY res := CallLie("Demazure", arg[2], arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: POLY res := CallLie("Demazure", arg[2], arg[1]); else Error( "LiE has no function \"Demazure\" for these types" ); fi; return res; end; ############################################################################# ## #F LieKL_poly . . . . . . . . . . . . . . . call the LiE function "KL_poly" ## LieKL_poly := function( arg ) local res; if Length(arg) = 3 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsVector(arg[3]) then # return type: POLY res := CallLie("KL_poly", arg[2], arg[3], arg[1]); else Error( "LiE has no function \"KL_poly\" for these types" ); fi; return res; end; ############################################################################# ## #F LieLR_tensor . . . . . . . . . . . . . call the LiE function "LR_tensor" ## LieLR_tensor := function( arg ) local res; if Length(arg) = 2 and IsVector(arg[1]) and IsVector(arg[2]) then # return type: POLY res := CallLie("LR_tensor", arg[1], arg[2]); elif Length(arg) = 2 and IsLiePoly(arg[1]) and IsLiePoly(arg[2]) then # return type: POLY res := CallLie("LR_tensor", arg[1], arg[2]); else Error( "LiE has no function \"LR_tensor\" for these types" ); fi; return res; end; ############################################################################# ## #F LieRS . . . . . . . . . . . . . . . . . . . . call the LiE function "RS" ## LieRS := function( arg ) local res; if Length(arg) = 1 and IsVector(arg[1]) then # return type: MATRIX res := CallLie("RS", arg[1]); elif Length(arg) = 2 and IsVector(arg[1]) and IsVector(arg[2]) then # return type: VECTOR res := CallLie("RS", arg[1], arg[2]); else Error( "LiE has no function \"RS\" for these types" ); fi; return res; end; ############################################################################# ## #F LieR_poly . . . . . . . . . . . . . . . . call the LiE function "R_poly" ## LieR_poly := function( arg ) local res; if Length(arg) = 3 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsVector(arg[3]) then # return type: POLY res := CallLie("R_poly", arg[2], arg[3], arg[1]); else Error( "LiE has no function \"R_poly\" for these types" ); fi; return res; end; ############################################################################# ## #F LieW_action . . . . . . . . . . . . . . call the LiE function "W_action" ## LieW_action := function( arg ) local res; if Length(arg) = 3 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsVector(arg[3]) then # return type: VECTOR res := CallLie("W_action", arg[2], arg[3], arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: MATRIX res := CallLie("W_action", arg[2], arg[1]); elif Length(arg) = 3 and IsLieGroup(arg[1]) and IsMatrix(arg[2]) and IsVector(arg[3]) then # return type: MATRIX res := CallLie("W_action", arg[2], arg[3], arg[1]); elif Length(arg) = 3 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) and IsVector(arg[3]) then # return type: POLY res := CallLie("W_action", arg[2], arg[3], arg[1]); else Error( "LiE has no function \"W_action\" for these types" ); fi; return res; end; ############################################################################# ## #F LieW_orbit . . . . . . . . . . . . . . . call the LiE function "W_orbit" ## LieW_orbit := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: MATRIX res := CallLie("W_orbit", arg[2], arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) then # return type: POLY res := CallLie("W_orbit", arg[2], arg[1]); else Error( "LiE has no function \"W_orbit\" for these types" ); fi; return res; end; ############################################################################# ## #F LieW_orbit_size . . . . . . . . . . call the LiE function "W_orbit_size" ## LieW_orbit_size := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: INTEGER res := CallLie("W_orbit_size", arg[2], arg[1]); else Error( "LiE has no function \"W_orbit_size\" for these types" ); fi; return res; end; ############################################################################# ## #F LieW_order . . . . . . . . . . . . . . . call the LiE function "W_order" ## LieW_order := function( arg ) local res; if Length(arg) = 1 and IsLieGroup(arg[1]) then # return type: INTEGER res := CallLie("W_order", arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: INTEGER res := CallLie("W_order", arg[2], arg[1]); else Error( "LiE has no function \"W_order\" for these types" ); fi; return res; end; ############################################################################# ## #F LieW_rt_action . . . . . . . . . . . call the LiE function "W_rt_action" ## LieW_rt_action := function( arg ) local res; if Length(arg) = 3 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsVector(arg[3]) then # return type: VECTOR res := CallLie("W_rt_action", arg[2], arg[3], arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: MATRIX res := CallLie("W_rt_action", arg[2], arg[1]); elif Length(arg) = 3 and IsLieGroup(arg[1]) and IsMatrix(arg[2]) and IsVector(arg[3]) then # return type: MATRIX res := CallLie("W_rt_action", arg[2], arg[3], arg[1]); else Error( "LiE has no function \"W_rt_action\" for these types" ); fi; return res; end; ############################################################################# ## #F LieW_rt_orbit . . . . . . . . . . . . call the LiE function "W_rt_orbit" ## LieW_rt_orbit := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: MATRIX res := CallLie("W_rt_orbit", arg[2], arg[1]); else Error( "LiE has no function \"W_rt_orbit\" for these types" ); fi; return res; end; ############################################################################# ## #F LieW_word . . . . . . . . . . . . . . . . call the LiE function "W_word" ## LieW_word := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: VECTOR res := CallLie("W_word", arg[2], arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsMatrix(arg[2]) then # return type: VECTOR res := CallLie("W_word", arg[2], arg[1]); else Error( "LiE has no function \"W_word\" for these types" ); fi; return res; end; ############################################################################# ## #F Lieadjoint . . . . . . . . . . . . . . . call the LiE function "adjoint" ## Lieadjoint := function( arg ) local res; if Length(arg) = 1 and IsLieGroup(arg[1]) then # return type: POLY res := CallLie("adjoint", arg[1]); else Error( "LiE has no function \"adjoint\" for these types" ); fi; return res; end; ############################################################################# ## #F Liealt_W_sum . . . . . . . . . . . . . call the LiE function "alt_W_sum" ## Liealt_W_sum := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) then # return type: POLY res := CallLie("alt_W_sum", arg[2], arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: POLY res := CallLie("alt_W_sum", arg[2], arg[1]); else Error( "LiE has no function \"alt_W_sum\" for these types" ); fi; return res; end; ############################################################################# ## #F Liealt_dom . . . . . . . . . . . . . . . call the LiE function "alt_dom" ## Liealt_dom := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) then # return type: POLY res := CallLie("alt_dom", arg[2], arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: POLY res := CallLie("alt_dom", arg[2], arg[1]); elif Length(arg) = 3 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) and IsVector(arg[3]) then # return type: POLY res := CallLie("alt_dom", arg[2], arg[3], arg[1]); elif Length(arg) = 3 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsVector(arg[3]) then # return type: POLY res := CallLie("alt_dom", arg[2], arg[3], arg[1]); else Error( "LiE has no function \"alt_dom\" for these types" ); fi; return res; end; ############################################################################# ## #F Liealt_tensor . . . . . . . . . . . . call the LiE function "alt_tensor" ## Liealt_tensor := function( arg ) local res; if Length(arg) = 3 and IsLieGroup(arg[1]) and IsInt(arg[2]) and IsVector(arg[3]) then # return type: POLY res := CallLie("alt_tensor", arg[2], arg[3], arg[1]); elif Length(arg) = 3 and IsLieGroup(arg[1]) and IsInt(arg[2]) and IsLiePoly(arg[3]) then # return type: POLY res := CallLie("alt_tensor", arg[2], arg[3], arg[1]); else Error( "LiE has no function \"alt_tensor\" for these types" ); fi; return res; end; ############################################################################# ## #F Liebranch . . . . . . . . . . . . . . . . call the LiE function "branch" ## Liebranch := function( arg ) local res; if Length(arg) = 4 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsLieGroup(arg[3]) and IsMatrix(arg[4]) then # return type: POLY res := CallLie("branch", arg[2], arg[3], arg[4], arg[1]); elif Length(arg) = 4 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) and IsLieGroup(arg[3]) and IsMatrix(arg[4]) then # return type: POLY res := CallLie("branch", arg[2], arg[3], arg[4], arg[1]); else Error( "LiE has no function \"branch\" for these types" ); fi; return res; end; ############################################################################# ## #F Liecanonical . . . . . . . . . . . . . call the LiE function "canonical" ## Liecanonical := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: VECTOR res := CallLie("canonical", arg[2], arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsMatrix(arg[2]) then # return type: MATRIX res := CallLie("canonical", arg[2], arg[1]); else Error( "LiE has no function \"canonical\" for these types" ); fi; return res; end; ############################################################################# ## #F Liecent_roots . . . . . . . . . . . . call the LiE function "cent_roots" ## Liecent_roots := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: MATRIX res := CallLie("cent_roots", arg[2], arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsMatrix(arg[2]) then # return type: MATRIX res := CallLie("cent_roots", arg[2], arg[1]); else Error( "LiE has no function \"cent_roots\" for these types" ); fi; return res; end; ############################################################################# ## #F Liecenter . . . . . . . . . . . . . . . . call the LiE function "center" ## Liecenter := function( arg ) local res; if Length(arg) = 1 and IsLieGroup(arg[1]) then # return type: MATRIX res := CallLie("center", arg[1]); else Error( "LiE has no function \"center\" for these types" ); fi; return res; end; ############################################################################# ## #F Liecentr_type . . . . . . . . . . . . call the LiE function "centr_type" ## Liecentr_type := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: GROUP res := CallLie("centr_type", arg[2], arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsMatrix(arg[2]) then # return type: GROUP res := CallLie("centr_type", arg[2], arg[1]); else Error( "LiE has no function \"centr_type\" for these types" ); fi; return res; end; ############################################################################# ## #F Lieclass_ord . . . . . . . . . . . . . call the LiE function "class_ord" ## Lieclass_ord := function( arg ) local res; if Length(arg) = 1 and IsVector(arg[1]) then # return type: INTEGER res := CallLie("class_ord", arg[1]); else Error( "LiE has no function \"class_ord\" for these types" ); fi; return res; end; ############################################################################# ## #F Lieclosure . . . . . . . . . . . . . . . call the LiE function "closure" ## Lieclosure := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsMatrix(arg[2]) then # return type: MATRIX res := CallLie("closure", arg[2], arg[1]); else Error( "LiE has no function \"closure\" for these types" ); fi; return res; end; ############################################################################# ## #F Liecollect . . . . . . . . . . . . . . . call the LiE function "collect" ## Liecollect := function( arg ) local res; if Length(arg) = 4 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) and IsLieGroup(arg[3]) and IsMatrix(arg[4]) then # return type: POLY res := CallLie("collect", arg[2], arg[3], arg[4], arg[1]); elif Length(arg) = 5 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) and IsLieGroup(arg[3]) and IsMatrix(arg[4]) and IsInt(arg[5]) then # return type: POLY res := CallLie("collect", arg[2], arg[3], arg[4], arg[5], arg[1]); else Error( "LiE has no function \"collect\" for these types" ); fi; return res; end; ############################################################################# ## #F Liecontragr . . . . . . . . . . . . . . call the LiE function "contragr" ## Liecontragr := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: VECTOR res := CallLie("contragr", arg[2], arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) then # return type: POLY res := CallLie("contragr", arg[2], arg[1]); else Error( "LiE has no function \"contragr\" for these types" ); fi; return res; end; ############################################################################# ## #F Liedecomp . . . . . . . . . . . . . . . . call the LiE function "decomp" ## Liedecomp := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) then # return type: POLY res := CallLie("decomp", arg[2], arg[1]); else Error( "LiE has no function \"decomp\" for these types" ); fi; return res; end; ############################################################################# ## #F Liedet_Cartan . . . . . . . . . . . . call the LiE function "det_Cartan" ## Liedet_Cartan := function( arg ) local res; if Length(arg) = 1 and IsLieGroup(arg[1]) then # return type: INTEGER res := CallLie("det_Cartan", arg[1]); else Error( "LiE has no function \"det_Cartan\" for these types" ); fi; return res; end; ############################################################################# ## #F Liedim . . . . . . . . . . . . . . . . . . . call the LiE function "dim" ## Liedim := function( arg ) local res; if Length(arg) = 1 and IsLieGroup(arg[1]) then # return type: INTEGER res := CallLie("dim", arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: INTEGER res := CallLie("dim", arg[2], arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) then # return type: INTEGER res := CallLie("dim", arg[2], arg[1]); else Error( "LiE has no function \"dim\" for these types" ); fi; return res; end; ############################################################################# ## #F Liedom_char . . . . . . . . . . . . . . call the LiE function "dom_char" ## Liedom_char := function( arg ) local res; if Length(arg) = 3 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsVector(arg[3]) then # return type: INTEGER res := CallLie("dom_char", arg[2], arg[3], arg[1]); elif Length(arg) = 3 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) and IsVector(arg[3]) then # return type: INTEGER res := CallLie("dom_char", arg[2], arg[3], arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: POLY res := CallLie("dom_char", arg[2], arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) then # return type: POLY res := CallLie("dom_char", arg[2], arg[1]); else Error( "LiE has no function \"dom_char\" for these types" ); fi; return res; end; ############################################################################# ## #F Liedom_weights . . . . . . . . . . . call the LiE function "dom_weights" ## Liedom_weights := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: MATRIX res := CallLie("dom_weights", arg[2], arg[1]); else Error( "LiE has no function \"dom_weights\" for these types" ); fi; return res; end; ############################################################################# ## #F Liedominant . . . . . . . . . . . . . . call the LiE function "dominant" ## Liedominant := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: VECTOR res := CallLie("dominant", arg[2], arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsMatrix(arg[2]) then # return type: MATRIX res := CallLie("dominant", arg[2], arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) then # return type: POLY res := CallLie("dominant", arg[2], arg[1]); else Error( "LiE has no function \"dominant\" for these types" ); fi; return res; end; ############################################################################# ## #F Lieexponents . . . . . . . . . . . . . call the LiE function "exponents" ## Lieexponents := function( arg ) local res; if Length(arg) = 1 and IsLieGroup(arg[1]) then # return type: VECTOR res := CallLie("exponents", arg[1]); else Error( "LiE has no function \"exponents\" for these types" ); fi; return res; end; ############################################################################# ## #F Liefilter_dom . . . . . . . . . . . . call the LiE function "filter_dom" ## Liefilter_dom := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsMatrix(arg[2]) then # return type: MATRIX res := CallLie("filter_dom", arg[2], arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) then # return type: POLY res := CallLie("filter_dom", arg[2], arg[1]); else Error( "LiE has no function \"filter_dom\" for these types" ); fi; return res; end; ############################################################################# ## #F Liefrom_part . . . . . . . . . . . . . call the LiE function "from_part" ## Liefrom_part := function( arg ) local res; if Length(arg) = 1 and IsVector(arg[1]) then # return type: VECTOR res := CallLie("from_part", arg[1]); elif Length(arg) = 1 and IsMatrix(arg[1]) then # return type: MATRIX res := CallLie("from_part", arg[1]); elif Length(arg) = 1 and IsLiePoly(arg[1]) then # return type: POLY res := CallLie("from_part", arg[1]); else Error( "LiE has no function \"from_part\" for these types" ); fi; return res; end; ############################################################################# ## #F Liefundam . . . . . . . . . . . . . . . . call the LiE function "fundam" ## Liefundam := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsMatrix(arg[2]) then # return type: MATRIX res := CallLie("fundam", arg[2], arg[1]); else Error( "LiE has no function \"fundam\" for these types" ); fi; return res; end; ############################################################################# ## #F Liehigh_root . . . . . . . . . . . . . call the LiE function "high_root" ## Liehigh_root := function( arg ) local res; if Length(arg) = 1 and IsLieGroup(arg[1]) then # return type: VECTOR res := CallLie("high_root", arg[1]); else Error( "LiE has no function \"high_root\" for these types" ); fi; return res; end; ############################################################################# ## #F Liei_Cartan . . . . . . . . . . . . . . call the LiE function "i_Cartan" ## Liei_Cartan := function( arg ) local res; if Length(arg) = 1 and IsLieGroup(arg[1]) then # return type: MATRIX res := CallLie("i_Cartan", arg[1]); else Error( "LiE has no function \"i_Cartan\" for these types" ); fi; return res; end; ############################################################################# ## #F Lieinprod . . . . . . . . . . . . . . . . call the LiE function "inprod" ## Lieinprod := function( arg ) local res; if Length(arg) = 3 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsVector(arg[3]) then # return type: INTEGER res := CallLie("inprod", arg[2], arg[3], arg[1]); else Error( "LiE has no function \"inprod\" for these types" ); fi; return res; end; ############################################################################# ## #F Liel_reduce . . . . . . . . . . . . . . call the LiE function "l_reduce" ## Liel_reduce := function( arg ) local res; if Length(arg) = 3 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsVector(arg[3]) then # return type: VECTOR res := CallLie("l_reduce", arg[2], arg[3], arg[1]); else Error( "LiE has no function \"l_reduce\" for these types" ); fi; return res; end; ############################################################################# ## #F Lielength . . . . . . . . . . . . . . . . call the LiE function "length" ## Lielength := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: INTEGER res := CallLie("length", arg[2], arg[1]); else Error( "LiE has no function \"length\" for these types" ); fi; return res; end; ############################################################################# ## #F Lielong_word . . . . . . . . . . . . . call the LiE function "long_word" ## Lielong_word := function( arg ) local res; if Length(arg) = 1 and IsLieGroup(arg[1]) then # return type: VECTOR res := CallLie("long_word", arg[1]); else Error( "LiE has no function \"long_word\" for these types" ); fi; return res; end; ############################################################################# ## #F Lielr_reduce . . . . . . . . . . . . . call the LiE function "lr_reduce" ## Lielr_reduce := function( arg ) local res; if Length(arg) = 4 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsVector(arg[3]) and IsVector(arg[4]) then # return type: VECTOR res := CallLie("lr_reduce", arg[2], arg[3], arg[4], arg[1]); else Error( "LiE has no function \"lr_reduce\" for these types" ); fi; return res; end; ############################################################################# ## #F Lien_pos_roots . . . . . . . . . . . call the LiE function "n_pos_roots" ## Lien_pos_roots := function( arg ) local res; if Length(arg) = 1 and IsLieGroup(arg[1]) then # return type: INTEGER res := CallLie("n_pos_roots", arg[1]); else Error( "LiE has no function \"n_pos_roots\" for these types" ); fi; return res; end; ############################################################################# ## #F Lien_tabl . . . . . . . . . . . . . . . . call the LiE function "n_tabl" ## Lien_tabl := function( arg ) local res; if Length(arg) = 1 and IsVector(arg[1]) then # return type: INTEGER res := CallLie("n_tabl", arg[1]); else Error( "LiE has no function \"n_tabl\" for these types" ); fi; return res; end; ############################################################################# ## #F Lienext_part . . . . . . . . . . . . . call the LiE function "next_part" ## Lienext_part := function( arg ) local res; if Length(arg) = 1 and IsVector(arg[1]) then # return type: VECTOR res := CallLie("next_part", arg[1]); else Error( "LiE has no function \"next_part\" for these types" ); fi; return res; end; ############################################################################# ## #F Lienext_perm . . . . . . . . . . . . . call the LiE function "next_perm" ## Lienext_perm := function( arg ) local res; if Length(arg) = 1 and IsVector(arg[1]) then # return type: VECTOR res := CallLie("next_perm", arg[1]); else Error( "LiE has no function \"next_perm\" for these types" ); fi; return res; end; ############################################################################# ## #F Lienext_tabl . . . . . . . . . . . . . call the LiE function "next_tabl" ## Lienext_tabl := function( arg ) local res; if Length(arg) = 1 and IsVector(arg[1]) then # return type: VECTOR res := CallLie("next_tabl", arg[1]); else Error( "LiE has no function \"next_tabl\" for these types" ); fi; return res; end; ############################################################################# ## #F Lienorm . . . . . . . . . . . . . . . . . . call the LiE function "norm" ## Lienorm := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: INTEGER res := CallLie("norm", arg[2], arg[1]); else Error( "LiE has no function \"norm\" for these types" ); fi; return res; end; ############################################################################# ## #F Lieorbit . . . . . . . . . . . . . . . . . call the LiE function "orbit" ## Lieorbit := function( arg ) local res; if Length(arg) = 3 and IsInt(arg[1]) and IsVector(arg[2]) and IsMatrix(arg[3]) then # return type: MATRIX res := CallLie("orbit", arg[1], arg[2], arg[3]); elif Length(arg) = 2 and IsVector(arg[1]) and IsMatrix(arg[2]) then # return type: MATRIX res := CallLie("orbit", arg[1], arg[2]); else Error( "LiE has no function \"orbit\" for these types" ); fi; return res; end; ############################################################################# ## #F Liep_tensor . . . . . . . . . . . . . . call the LiE function "p_tensor" ## Liep_tensor := function( arg ) local res; if Length(arg) = 3 and IsLieGroup(arg[1]) and IsInt(arg[2]) and IsVector(arg[3]) then # return type: POLY res := CallLie("p_tensor", arg[2], arg[3], arg[1]); elif Length(arg) = 3 and IsLieGroup(arg[1]) and IsInt(arg[2]) and IsLiePoly(arg[3]) then # return type: POLY res := CallLie("p_tensor", arg[2], arg[3], arg[1]); else Error( "LiE has no function \"p_tensor\" for these types" ); fi; return res; end; ############################################################################# ## #F Liepartitions . . . . . . . . . . . . call the LiE function "partitions" ## Liepartitions := function( arg ) local res; if Length(arg) = 1 and IsInt(arg[1]) then # return type: MATRIX res := CallLie("partitions", arg[1]); else Error( "LiE has no function \"partitions\" for these types" ); fi; return res; end; ############################################################################# ## #F Lieplethysm . . . . . . . . . . . . . . call the LiE function "plethysm" ## Lieplethysm := function( arg ) local res; if Length(arg) = 3 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsVector(arg[3]) then # return type: POLY res := CallLie("plethysm", arg[2], arg[3], arg[1]); elif Length(arg) = 3 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsLiePoly(arg[3]) then # return type: POLY res := CallLie("plethysm", arg[2], arg[3], arg[1]); else Error( "LiE has no function \"plethysm\" for these types" ); fi; return res; end; ############################################################################# ## #F Liepos_roots . . . . . . . . . . . . . call the LiE function "pos_roots" ## Liepos_roots := function( arg ) local res; if Length(arg) = 1 and IsLieGroup(arg[1]) then # return type: MATRIX res := CallLie("pos_roots", arg[1]); else Error( "LiE has no function \"pos_roots\" for these types" ); fi; return res; end; ############################################################################# ## #F Lier_reduce . . . . . . . . . . . . . . call the LiE function "r_reduce" ## Lier_reduce := function( arg ) local res; if Length(arg) = 3 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsVector(arg[3]) then # return type: VECTOR res := CallLie("r_reduce", arg[2], arg[3], arg[1]); else Error( "LiE has no function \"r_reduce\" for these types" ); fi; return res; end; ############################################################################# ## #F Liereduce . . . . . . . . . . . . . . . . call the LiE function "reduce" ## Liereduce := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: VECTOR res := CallLie("reduce", arg[2], arg[1]); else Error( "LiE has no function \"reduce\" for these types" ); fi; return res; end; ############################################################################# ## #F Liereflection . . . . . . . . . . . . call the LiE function "reflection" ## Liereflection := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: MATRIX res := CallLie("reflection", arg[2], arg[1]); else Error( "LiE has no function \"reflection\" for these types" ); fi; return res; end; ############################################################################# ## #F Lieres_mat . . . . . . . . . . . . . . . call the LiE function "res_mat" ## Lieres_mat := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsMatrix(arg[2]) then # return type: MATRIX res := CallLie("res_mat", arg[2], arg[1]); else Error( "LiE has no function \"res_mat\" for these types" ); fi; return res; end; ############################################################################# ## #F Lieshape . . . . . . . . . . . . . . . . . call the LiE function "shape" ## Lieshape := function( arg ) local res; if Length(arg) = 1 and IsVector(arg[1]) then # return type: VECTOR res := CallLie("shape", arg[1]); else Error( "LiE has no function \"shape\" for these types" ); fi; return res; end; ############################################################################# ## #F Liesign_part . . . . . . . . . . . . . call the LiE function "sign_part" ## Liesign_part := function( arg ) local res; if Length(arg) = 1 and IsVector(arg[1]) then # return type: INTEGER res := CallLie("sign_part", arg[1]); else Error( "LiE has no function \"sign_part\" for these types" ); fi; return res; end; ############################################################################# ## #F Liespectrum . . . . . . . . . . . . . . call the LiE function "spectrum" ## Liespectrum := function( arg ) local res; if Length(arg) = 3 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsVector(arg[3]) then # return type: POLY res := CallLie("spectrum", arg[2], arg[3], arg[1]); elif Length(arg) = 3 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) and IsVector(arg[3]) then # return type: POLY res := CallLie("spectrum", arg[2], arg[3], arg[1]); else Error( "LiE has no function \"spectrum\" for these types" ); fi; return res; end; ############################################################################# ## #F Liesym_char . . . . . . . . . . . . . . call the LiE function "sym_char" ## Liesym_char := function( arg ) local res; if Length(arg) = 2 and IsVector(arg[1]) and IsVector(arg[2]) then # return type: INTEGER res := CallLie("sym_char", arg[1], arg[2]); elif Length(arg) = 1 and IsVector(arg[1]) then # return type: MATRIX res := CallLie("sym_char", arg[1]); else Error( "LiE has no function \"sym_char\" for these types" ); fi; return res; end; ############################################################################# ## #F Liesym_orbit . . . . . . . . . . . . . call the LiE function "sym_orbit" ## Liesym_orbit := function( arg ) local res; if Length(arg) = 1 and IsVector(arg[1]) then # return type: MATRIX res := CallLie("sym_orbit", arg[1]); else Error( "LiE has no function \"sym_orbit\" for these types" ); fi; return res; end; ############################################################################# ## #F Liesym_tensor . . . . . . . . . . . . call the LiE function "sym_tensor" ## Liesym_tensor := function( arg ) local res; if Length(arg) = 3 and IsLieGroup(arg[1]) and IsInt(arg[2]) and IsVector(arg[3]) then # return type: POLY res := CallLie("sym_tensor", arg[2], arg[3], arg[1]); elif Length(arg) = 3 and IsLieGroup(arg[1]) and IsInt(arg[2]) and IsLiePoly(arg[3]) then # return type: POLY res := CallLie("sym_tensor", arg[2], arg[3], arg[1]); else Error( "LiE has no function \"sym_tensor\" for these types" ); fi; return res; end; ############################################################################# ## #F Lietableaux . . . . . . . . . . . . . . call the LiE function "tableaux" ## Lietableaux := function( arg ) local res; if Length(arg) = 1 and IsVector(arg[1]) then # return type: MATRIX res := CallLie("tableaux", arg[1]); else Error( "LiE has no function \"tableaux\" for these types" ); fi; return res; end; ############################################################################# ## #F Lietensor . . . . . . . . . . . . . . . . call the LiE function "tensor" ## Lietensor := function( arg ) local res; if Length(arg) = 3 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsVector(arg[3]) then # return type: POLY res := CallLie("tensor", arg[2], arg[3], arg[1]); elif Length(arg) = 3 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) and IsLiePoly(arg[3]) then # return type: POLY res := CallLie("tensor", arg[2], arg[3], arg[1]); elif Length(arg) = 4 and IsLieGroup(arg[1]) and IsVector(arg[2]) and IsVector(arg[3]) and IsVector(arg[4]) then # return type: INTEGER res := CallLie("tensor", arg[2], arg[3], arg[4], arg[1]); elif Length(arg) = 4 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) and IsLiePoly(arg[3]) and IsVector(arg[4]) then # return type: INTEGER res := CallLie("tensor", arg[2], arg[3], arg[4], arg[1]); else Error( "LiE has no function \"tensor\" for these types" ); fi; return res; end; ############################################################################# ## #F Lieto_part . . . . . . . . . . . . . . . call the LiE function "to_part" ## Lieto_part := function( arg ) local res; if Length(arg) = 1 and IsVector(arg[1]) then # return type: VECTOR res := CallLie("to_part", arg[1]); elif Length(arg) = 1 and IsMatrix(arg[1]) then # return type: MATRIX res := CallLie("to_part", arg[1]); elif Length(arg) = 1 and IsLiePoly(arg[1]) then # return type: POLY res := CallLie("to_part", arg[1]); else Error( "LiE has no function \"to_part\" for these types" ); fi; return res; end; ############################################################################# ## #F Lietrans_part . . . . . . . . . . . . call the LiE function "trans_part" ## Lietrans_part := function( arg ) local res; if Length(arg) = 1 and IsVector(arg[1]) then # return type: VECTOR res := CallLie("trans_part", arg[1]); else Error( "LiE has no function \"trans_part\" for these types" ); fi; return res; end; ############################################################################# ## #F Liev_decomp . . . . . . . . . . . . . . call the LiE function "v_decomp" ## Liev_decomp := function( arg ) local res; if Length(arg) = 2 and IsLieGroup(arg[1]) and IsLiePoly(arg[2]) then # return type: POLY res := CallLie("v_decomp", arg[2], arg[1]); elif Length(arg) = 2 and IsLieGroup(arg[1]) and IsVector(arg[2]) then # return type: POLY res := CallLie("v_decomp", arg[2], arg[1]); else Error( "LiE has no function \"v_decomp\" for these types" ); fi; return res; end; LiE/gapfiles/liegap.g0000644000175000017500000000251406217540772013674 0ustar hakanhakanLIE := 0; EXEC := function( arg ) Exec( Concatenation( List( arg, String ) ) ); end; StringLiePolynomial := function( l ) local cmd, i; cmd := ""; for i in [ 1, 3 .. Length(l)-1 ] do if 1 < i then Append( cmd, "+\n" ); fi; Append( cmd, StringInt(l[i]) ); Append( cmd, "X" ); Append( cmd, String(l[i+1]) ); od; return cmd; end; IsMatrix := IsMat; IsLieGroup := IsString; IsLiePoly := function(obj) return IsList(obj) and 1 < Length(obj) and IsInt(obj[1]) and IsList(obj[2]); end; CallLie := function( arg ) local intmp, outtmp, cmd, i; intmp := TmpName(); EXEC( "touch ", intmp ); outtmp := TmpName(); EXEC( "touch ", outtmp ); cmd := "LIE = "; Append( cmd, arg[1] ); Append( cmd, "( " ); for i in [ 2 .. Length(arg) ] do if 2 < i then Append( cmd, ", " ); fi; if IsLiePoly(arg[i]) then Append( cmd, StringLiePolynomial(arg[i]) ); else Append( cmd, String(arg[i]) ); fi; od; Append( cmd, " )\n" ); Append( cmd, "? LIE > " ); Append( cmd, outtmp ); Append( cmd, "\n" ); PrintTo( intmp, cmd ); Unbind(LIE); EXEC( "cd LiE; ./Liegap.exe > /dev/null < ", intmp ); Read(outtmp); return LIE; end; LiE/gapfiles/script.g0000644000175000017500000000655706217536054013750 0ustar hakanhakanGenerateFunction := function( l, n ) local cmd, cmd2, cmd3, f, i, j, m; cmd := "#############################################################################"; Append( cmd, "\n##\n" ); cmd2 := "#F "; Append( cmd2, "Lie" ); Append( cmd2, n ); cmd3 := "call the LiE function \""; Append( cmd3, n ); Append( cmd3, "\"" ); Append( cmd2, " " ); if Length(cmd2) mod 2 = 0 then Append( cmd2, " " ); fi; while Length(cmd3)+Length(cmd2) < 76 do Append( cmd2, ". " ); od; if Length(cmd3)+Length(cmd2) = 76 then Append( cmd2, " " ); fi; Append( cmd, cmd2 ); Append( cmd, cmd3 ); Append( cmd, "\n##\n" ); f := Filtered( l, x -> x[1] = n ); cmd := Concatenation( cmd, "Lie" ); Append( cmd, n ); Append( cmd, " := function( arg )\n local res;\n\n" ); for i in [ 1 .. Length(f) ] do m := [ 1 .. Length(f[i])-2 ]; if f[i][Length(f[i])] = GRPDFT then f[i] := Copy(f[i]); f[i]{[4..Length(f[i])]} := f[i]{[3..Length(f[i])-1]}; f[i][3] := GRPDFT; m := Concatenation( [2..Length(f[i])-2], [1] ); fi; if i = 1 then Append( cmd, " if " ); else Append( cmd, " elif " ); fi; cmd := Concatenation( cmd, " Length(arg) = ", String(Length(f[i])-2) ); for j in [ 3 .. Length(f[i]) ] do Append( cmd, "\n and " ); if f[i][j] = MATRIX then cmd := Concatenation( cmd, "IsMatrix(arg[",String(j-2),"])" ); elif f[i][j] = GRPDFT then cmd := Concatenation( cmd, "IsLieGroup(arg[",String(j-2),"])" ); elif f[i][j] = INTEGER then cmd := Concatenation( cmd, "IsInt(arg[",String(j-2),"])" ); elif f[i][j] = VECTOR then cmd := Concatenation( cmd, "IsVector(arg[",String(j-2),"])" ); elif f[i][j] = POLY then cmd := Concatenation( cmd, "IsLiePolynomial(arg[",String(j-2),"])" ); elif f[i][j] = GROUP then cmd := Concatenation( cmd, "IsLieGroup(arg[",String(j-2),"])" ); fi; od; cmd := Concatenation( cmd, "\n then\n" ); cmd := Concatenation( cmd, " # return type: " ); if f[i][2] = MATRIX then cmd := Concatenation( cmd, "MATRIX\n" ); elif f[i][2] = VECTOR then cmd := Concatenation( cmd, "VECTOR\n" ); elif f[i][2] = POLY then cmd := Concatenation( cmd, "POLY\n" ); elif f[i][2] = INTEGER then cmd := Concatenation( cmd, "INTEGER\n" ); elif f[i][2] = GROUP then cmd := Concatenation( cmd, "GROUP\n" ); fi; cmd := Concatenation( cmd, " res := CallLie(\"", n, "\"" ); for j in [ 3 .. Length(f[i]) ] do cmd := Concatenation( cmd, ", " ); cmd := Concatenation( cmd, "arg[", String(m[j-2]), "]" ); od; cmd := Concatenation( cmd, ");\n" ); od; cmd := Concatenation( cmd, " else\n Error( \"" ); cmd := Concatenation( cmd, "LiE has no function \\\"", n, "\\\"", " for these types" ); cmd := Concatenation( cmd, "\" );\n fi;\n return res;" ); cmd := Concatenation( cmd, "\n\nend;\n\n\n" ); return cmd; end; LiE/getl.c0000664000175000017500000000361407073315526011572 0ustar hakanhakan/* this file defines the input interface to the lexical scanner */ #include "lie.h" extern boolean stop; /* ignore following stuff if not using readline */ #ifdef preprocessor /* Instead of #including files we simply state the few declarations needed. This was needed because on some systems the included files would contain stuff that conflicts with that in "lie.h" (notably the typedef of |index|). */ typedef int Function (void); extern char* readline (char*); extern void add_history (char*); extern int rl_insert (void); extern int rl_bind_key(int, Function*); /* A static variable for holding the line. */ static char* line_read = NULL; /* prompt, read a string, and set |line_read| to it, or to |NULL| on |EOF| */ void fetch_line (char *prompt_string) { if (redirected_input || cur_in!=stdin) return; if (line_read != NULL) { free(line_read); line_read = NULL; } if (!prompt) prompt_string=""; else if (am_monitor) fprintf(monfile,"%s",prompt_string); line_read = readline(prompt_string); /* Get a line from the user. */ if (line_read!=NULL && line_read[0]!='\0') /* if line is not empty */ add_history(line_read); /* add it to the history */ } /* now get a character from |stdin|, in fact from the |line_read| buffer */ int fetch_char(void) { static int i=0; int c; if (redirected_input || cur_in!=stdin) c=getc(cur_in); else if (line_read==NULL) c=EOF; else if ((c=line_read[i++])=='\0') { i=0; c='\n'; } if (am_monitor && c!=EOF) putc(c,monfile); return c; } void initialize_readline(void) { rl_bind_key('\t',rl_insert); } #else void fetch_line(char *prompt_string) { if(!redirected_input && cur_in==stdin && prompt) { Printf("%s",prompt_string); if (am_monitor) fprintf(monfile,"%s",prompt_string); } } int fetch_char(void) { int c=getc(cur_in); if (am_monitor && c!=EOF) putc(c,monfile); return c; } void initialize_readline(void){} #endif LiE/getl.h0000664000175000017500000000012506233360310011555 0ustar hakanhakanint fetch_char(void); void initialize_readline(void); void fetch_line(char *prompt); LiE/infolrn.h0000664000175000017500000000100706233637267012313 0ustar hakanhakan#define LABELLENGTH 80 /* limit to length of file names and such */ #define MAX_INFO_FILES 10 #define KEYWORDLEN 32 #define N_PARENTS 4 typedef struct { char p[N_PARENTS][KEYWORDLEN]; short n; } parent_tp; /* record of INFO */ typedef struct { char keyword[KEYWORDLEN]; long start; short size; short seq; unsigned char narg,t[7]; parent_tp parents; int directory; } info_index_tp; typedef struct { char keyword[KEYWORDLEN]; long start; short size; } learn_index_tp; LiE/learn.c0000664000175000017500000001330307072416325011732 0ustar hakanhakan#include "lie.h" #define NRECS 80 /* Just enough for LiE 2.0 */ #define NCOLS 3 static char *directory_table[REPORT_LEN]; static int directory_pt = 0; extern char *getenv(); /* Learn reads the indexfile belonging to the learnfile, searching it for keywords containing the given name as substring. For each match, the corresponding part of the learn file is copied to the result string. */ static void add_directory_table(char* name) { int i = 0, j = directory_pt; if (directory_pt >= REPORT_LEN) error("Learn index too large.\n"); while (i < directory_pt && strcmp(directory_table[i], name) < 0) i++; if (i < directory_pt && !strcmp(directory_table[i], name)) return; while (j > i) { directory_table[j] = directory_table[j - 1]; j--; } if (!(*name)) error("Null name %d\n",i); directory_table[i] = name; directory_pt++; } static void printdirectory(void) { int i; for (i = 0; i < directory_pt - 1; i++) { if(strlen(directory_table[i]) > KEYWORDLEN) error("%s too long.\n",directory_table[i]); if (i % NCOLS == 0) Printf("\n"); Printf("%-24.24s ", directory_table[i]); } Printf("\n"); } boolean substring(key,name) char* name,* key; { char* keypt; if (!*name) return false; keypt = strchr(key,name[0]); while (keypt && strncmp(keypt,name,strlen(name))) keypt = strchr(keypt+1,name[0]); return keypt!=NULL; } void build_directory(learn,nitems) learn_index_tp* learn; long nitems; { long i=0; for (i=0;i= NRECS) error("Indexfile too large.\n"); if (*name=='\0' || strcmp(name,"index")==0) { if (directory_pt == 0) build_directory(learn,nitems); printdirectory(); return true; } /*************************************************************** * Make uppercase * ***************************************************************/ while (*t) { *t = isupper(*t)? tolower(*t): *t; t++; } /*************************************************************** * Search * ***************************************************************/ foundpt = 0; for (i=0;i NRECS) error("Indexfile too large.\n"); i = 0; /* printf("learn:%s name: %s\n",learn[i].keyword,name); */ /* Convert name to lowercase */ while (*t) { *t = isupper(*t)? tolower(*t): *t; t++; } /* Lineair search */ while(i < NRECS && strcmp(learn[i].keyword,name)) i++; if (i==NRECS) return -1; /* Not found */ return learn[i].start; } LiE/lie_script0000664000175000017500000000011006217267336012543 0ustar hakanhakanLD=actual directory gets substituted here exec $LD/Lie.exe initfile $LD LiE/make_lie0000755000175000017500000000011206217267753012162 0ustar hakanhakan#!/bin/sh sed -e "s!LD=.*!LD=`/bin/pwd`!" lie chmod a+x lie LiE/manual/0002775000175000017500000000000010722315511011733 5ustar hakanhakanLiE/output.c0000644000175000017500000000767507215142515012202 0ustar hakanhakan#include "lie.h" #include int Printf(char *format, ...) { va_list ap; int nc; va_start(ap, format); nc=vfprintf(cur_out, format, ap); if (am_monitor) vfprintf(monfile, format, ap); va_end(ap); return nc; } void err_Printf(char *format, ...) { va_list ap; va_start(ap,format); vfprintf(stderr, format, ap); if (am_monitor) vfprintf(monfile, format, ap); va_end(ap); } void error(char *format, ...) { symblst list; extern jmp_buf envbuf; va_list ap; va_start(ap, format); vfprintf(stderr, format, ap); if (am_monitor) vfprintf(monfile, format, ap); if (label->name) { boolean printin = (label->name != seq_name); if (printin) Printf("(in %s",name_tab[label->name]); if (no_terminal(cur_in) || strcmp(label->fname, "stdin")!=0) { if (!printin) Printf("("); Printf(" at line %d of file %s)\n",label->line, label->fname); } else if (printin) Printf(")\n"); } if (fun_name) Printf("[in function %s ]\n", name_tab[fun_name]); for (list = top_definitions; list!=NULL; list = list->next) /* Recover symbol table */ { if (list->class == FUNCTION_COPIED) list->class = FUNCTION; if (list->next && list->next->class == DUMMY) list->next = list->next->next; /* Remove sym */ } if (repair_obj) { setshared(repair_obj); repair_obj = (object) NULL; } if (cur_in==stdin) clear_input(); else do exit_input_file(parsing); while (cur_in!=stdin); /* pop input files */ longjmp(envbuf, -1); } void fatal(char *format, ...) { va_list ap; va_start(ap, format); (void) fprintf(stderr, "\n*** FATAL ERROR ***\n"); vfprintf(stderr, format, ap); abort(); } void monprintf(char *format, ...) { va_list ap; va_start(ap, format); if (am_monitor) vfprintf(monfile, format, ap); } void monitor_cmd(char* file_arg) { if (am_monitor) error("monitoring is already being done\n"); monfile = fopen(file_arg, "w"); if (monfile == NULL) error("can't open %s\n", file_arg); } void endmon(void) { if (!am_monitor) error("not monitoring at this moment\n"); monprintf("\n"); if (fclose(monfile)) error("error closing monitor file\n"); } void invoke_prog(char* prog, char* args) { size_t l=strlen(prog); char* buf=allocmem(l+strlen(args)+2); strcpy(buf,prog); buf[l]=' '; strcpy(&buf[l+1],args); system(buf); freem(buf); } typedef struct { char *name; FILE *fp; int line, tree_pt; } read_stack_tp; #define READ_STACK_LEN 10 /* Number of open read files */ static read_stack_tp read_stack[READ_STACK_LEN]; static int read_stack_pt=0; /* Calling |enter_input_file| will attempt to open the given file for reading commands, returning |true| on success, and returning |false| after undoing all preparations otherwise. */ boolean enter_input_file(char* name) { if (read_stack_pt >= READ_STACK_LEN) return false; read_stack[read_stack_pt].fp=cur_in; read_stack[read_stack_pt].line=lineno; read_stack[read_stack_pt].name=input_fname; read_stack[read_stack_pt].tree_pt=tree_pt; if ((cur_in=fopen(name,"r"))!=NULL) { ++read_stack_pt; lineno=1; input_fname=name_tab[match(name,true)]; /* make a secure copy */ return true; } cur_in=read_stack[read_stack_pt].fp; /* restore */ return false; } boolean exit_input_file(parse_error) { fclose(cur_in); if (read_stack_pt < 0) fatal("Exit_input_file.\n"); if (read_stack_pt == 0) { if (parse_error) fatal("No recovery possible.\n"); return true; } --read_stack_pt; cur_in=read_stack[read_stack_pt].fp; lineno=read_stack[read_stack_pt].line; input_fname=read_stack[read_stack_pt].name; if (parse_error) { tree_pt=read_stack[tree_pt].tree_pt; } return false; } /* Timing of computations */ static clock_t last_time; void registrate_cpu(void) { last_time=clock(); } void print_runtime(void) { long diff=clock()-last_time; Printf("\nComputation time %ld.%02ld sec.\n" , diff/CLOCKS_PER_SEC, (100*diff/CLOCKS_PER_SEC)%100); } LiE/parser.y0000644000175000017500000002703007112701674012152 0ustar hakanhakan%start command %{ #include "lie.h" %} %union { short sub; long val; bigint* num; symblst sym; char* text; } %token IF 1 THEN 2 ELSE 3 FI 4 FOR 5 TO 6 DOWNTO 7 IN 8 ROW 9 WHILE 10 DO 11 OD 12 LOC 13 RETURN 14 BREAK 15 MAKE 16 %token APPLY 17 ON 20 OFF 21 SETDEFAULT 22 SAVESTATE 23 RESTORESTATE 24 %token TYPEID 25 HELP 31 %token WHATTYPE 32 EDIT 33 READ 34 WRITE 35 MONFIL 36 LEARN 37 EXEC 38 QUIT 39 %token LISTCOMMAND 41 %token MAXNODES 44 MAXOBJECTS 45 %token WRITEHELP 18 APPENDHELP 19 %token INT 26 %token NUMBER 27 %token GROUPID 28 IDENT 29 DOLLAR 30 %token TEXT 40 %token ANY_STRING 42 %token ENTER 43 %token SEMICOLON 46 COMMA 47 BAR 48 COLON 49 %token LPAR 50 RPAR 51 LBRACE 52 RBRACE 53 LBRACK 54 RBRACK 55 %token OR 56 AND 57 NOT 58 TIMES 59 POWER 60 X 61 BECOMES 62 PLUSAB 63 %token RELOP 64 ADDOP 65 DIVOP 66 %type block series statlist statement assignment expression logical_expr op1 op2 op3 arithmetic_expr op6 op7 op8 monadic_expr secondary selection primary var simple_group group formals joined_formals varlist list_option list %type on %type string_opt %{ #include "parseaux.c" %} %% /*beginning of rules section */ command : ENTER | series ENTER { parsing = false; eval_type($1); /* global_pt=0; */ $1->type=ARGTYPE; eval_value($1); if ($1->data.val) { addsym(match("$",false),(symblst) NULL, $1, VALUE); vid_print($1->data.val); } } | function_definition ENTER | READ string_opt ENTER { char *filename = $2==NULL ? initfil : $2; boolean istty = !no_terminal(cur_in); /* not already reading from a file */ parsing=false; if (!enter_input_file(filename)) { Printf("Not possible to read file %s.\n",filename); YYERROR; } if (istty) strcpy(initfil, filename); } | EDIT string_opt ENTER { char *filename = $2==NULL ? initfil : $2; parsing=false; invoke_prog(editor,filename); if (!enter_input_file(filename)) Printf("File %s could not be read after editing.\n",filename); else strcpy(initfil,filename); /* set default for further reads */ } | WRITE ANY_STRING ENTER { parsing=false; listvars(top_definitions,$2); listfuns(top_definitions,$2); } | MONFIL string_opt ENTER { if ($2==NULL) Printf("%s\n",monfil); else if (strlen($2)>=LABELLENGTH) error("File name %s too long.\n",$2); else strcpy(monfil,$2); } | MAXOBJECTS ENTER { Printf("Maximum number of objects: %ld\n",(long)maxptrs); } | MAXOBJECTS INT ENTER { parsing=false; newmem($2); } | MAXNODES ENTER { Printf("Maximum number of nodes: %ld\n",(long)maxnodes); } | MAXNODES INT ENTER { parsing=false; maxnodes = $2; newtree(); } | LISTCOMMAND ENTER { if ($1==2) listops(top_definitions,NULL,true); else ($1==0 ? listvars :listfuns)(top_definitions,NULL); } | HELP string_opt WRITEHELP ANY_STRING ENTER { char* s = $2!=NULL ? $2 : $1 ? dir : help; parsing=false; write_key(s,$4,"w"); } | HELP string_opt APPENDHELP ANY_STRING ENTER { char* s = $2!=NULL ? $2 : $1 ? dir : help; parsing=false; write_key(s,$4,"a"); } | HELP string_opt ENTER { char* s = $2!=NULL ? $2 : $1 ? dir : help; parsing=false; printexpr(s,TO_LOOK,true); } | LEARN string_opt ENTER { parsing=false; if (!Learn($2==NULL ? "index" : $2)) { Printf("Info about %s is not available.\n",$2); YYERROR; } } | COLON ANY_STRING ENTER { parsing=false; invoke_prog($2,""); } | QUIT ENTER { if (cur_in != stdin) {fclose(cur_in);cur_in=stdin; } stop = true; } | WHATTYPE arithmetic_expr ENTER { parsing=false; eval_type($2); Printf("%10s ",code_class($2->class)); Printf("%10s \n",code_type($2->type)); } | EXEC ANY_STRING ENTER { entry pos = exec_learn($2); if (pos >= 0) { cur_in=fopen(learnfil,"r"); if (!cur_in) { Printf("%s not found.\n",learnfil); cur_in=stdin;YYERROR; } if (fseek(cur_in,pos,0)<0) { Printf("Unfortunate seek %s.\n",learnfil); cur_in=stdin;YYERROR; } } else { Printf("Info about %s is not available.\n",$2); cur_in = stdin; YYERROR; } lineno = 0; } ; block : LBRACE series RBRACE { $$=B(block_name,$2); } | LBRACE series RBRACE LPAR list RPAR { $$=B(block_name,$2); $$->arglst = $5; add_dollar_names($5); --tail_pt; } ; series : statlist { $$= addnode(1,seq_name,$1); } /* wrap up a series */ ; statlist: statement | statement SEMICOLON | statement SEMICOLON statlist { $$=$1; $$->next=$3; } | SEMICOLON statlist { $$ = $2; } ; statement : assignment | expression | RETURN expression { $$=addnode(1,match("_return",false),$2); } | BREAK expression { $$=addnode(1,match("_break",false),$2); } | RETURN { $$=addnode(0,match("_return",false)); } | BREAK { $$=addnode(0,match("_break",false)); } | SETDEFAULT { $$=addnode(0,match("_setdefault",false)); } | SETDEFAULT expression { $$=addnode(1,match("_setdefault",false),$2); } | on IDENT { $$=addnode(2,match("_on",false) ,addintnode($1),addtekstnode(name_tab[$2])); } | OFF IDENT { $$=addnode(2,match("_off",false) ,addintnode(OFFCODE),addtekstnode(name_tab[$2])); } | on { $$=addnode(0,match("_on",false)); } | OFF { $$=addnode(0,match("_off",false)); } | SAVESTATE { $$=addnode(0,match("save_options",false)); } | RESTORESTATE { $$=addnode(0,match("restore_options",false)); } ; on : ON { $$ = ONCODE; } | ON INT { if ($2 < 0) error("Argument %ld to 'on' is negative.\n",(long)($2)); $$ = $2; } | ON ADDOP { $$ = $2==0 ? PLUS : MINUS; } ; assignment : IDENT BECOMES expression { $$ = addnode(2,match(".assign",false),addnamenode($1),$3); } | LOC IDENT BECOMES expression { $$ = addnode(2,match(".assign_loc",false),addnamenode($2),$4); } | IDENT PLUSAB expression { $$ = addnode(2,match(".+=",false),addnamenode($1),$3); $$->arglst->type = UNKNOWN; } | selection BECOMES arithmetic_expr { /* a[i]=n = .update(a,n,i)) */ symblst lst = $1->arglst; check_variable($1->arglst); if ($1->a.label->name == match(Select,false)) $1->a.label->name = match(update,false); else $1->a.label->name = match(vecupdate,false); /* insert n */ $3->next = lst->next; /* Points to indexes */ lst->next = $3; $$ = $1; } | selection PLUSAB arithmetic_expr { symblst lst = $1->arglst; check_variable($1->arglst); if ($1->a.label->name == match(Select,false)) $1->a.label->name = match(plus_and_becomes,false); else error("error with operator `+='.\n"); $3->next = lst->next; /* points to indexes */ lst->next = $3; $$ = $1; } ; expression : logical_expr | arithmetic_expr ; logical_expr : expression OR op1 { $$=addnode(2,match("||",false),$1,$3); } | expression OR arithmetic_expr { $$=addnode(2,match("||",false),$1,$3); } | op1 ; op1 : op1 AND op2 { $$=addnode(2,match("&&",false),$1,$3); } | op1 AND arithmetic_expr { $$=addnode(2,match("&&",false),$1,$3); } | arithmetic_expr AND op2 { $$=addnode(2,match("&&",false),$1,$3); } | arithmetic_expr AND arithmetic_expr { $$=addnode(2,match("&&",false),$1,$3); } | op2 ; op2 : NOT op2 { $$=addnode(1,match("!",false),$2); } | NOT arithmetic_expr { $$=addnode(1,match("!",false),$2); } | op3 ; op3 : arithmetic_expr RELOP arithmetic_expr { static char s[][3]={ "==", "!=", "<", ">", "<=", ">=" }; $$=addnode(2,match(s[$2],false),$1,$3); } | LPAR logical_expr RPAR { $$=$2; } ; arithmetic_expr : arithmetic_expr ADDOP op6 { $$=addnode(2,match($2==0 ? "+" : "-",false),$1,$3); } | op6 ; op6 : op6 TIMES op7 { $$=addnode(2,match("*",false),$1,$3); } | op6 DIVOP op7 { $$=addnode(2,match($2==0 ? "/" : "%",false),$1,$3); } | op7 ; op7 : op7 POWER op8 { $$=addnode(2,match("^",false),$1,$3); } | op8 ; op8 : monadic_expr X monadic_expr { $$=addnode(2,match("X",false),$1,$3); } | monadic_expr ; monadic_expr : ADDOP monadic_expr { if ($1==1) $$=addnode(1,match("-",false),$2); else $$=$2; } | TIMES monadic_expr { $$=addnode(1,match("*",false),$2); } | X monadic_expr { $$=addnode(1,match("X",false),$2); } | secondary ; secondary : selection | primary ; selection : secondary LBRACK list RBRACK { symblst lst = $3; int i = 0; while (lst!=NULL) { lst=lst->next; ++i; } if (i>2) { parsing=false; error("Indexing with %d subscripts; at most 2 are allowed.\n",i); } $$=addnode(2,match(Select,false),$1,$3); --tail_pt; } | secondary BAR primary { $$=addnode(2,match("|",false),$1,$3); } ; primary : var | NUMBER { $$=addbigintnode($1); } | TEXT | group | IDENT LPAR RPAR { $$=addnode(0,$1); } | IDENT LPAR list RPAR { $$=addnode(1,$1,$3); --tail_pt; } | MAKE LPAR var COMMA arithmetic_expr RPAR { $$=addnode(2,match(".make",false),$3,$5); $3->arglst=addintnode(0); } | MAKE LPAR var COMMA arithmetic_expr COMMA arithmetic_expr RPAR { $$=addnode(3,match(".make",false),$3,$5,$7); $3->arglst=addintnode(0); $3->arglst->next=addintnode(0); } | APPLY LPAR var COMMA arithmetic_expr COMMA arithmetic_expr RPAR { char* s=$1==0 ? ".iapply" : $1==1 ? ".vapply" : ".mapply"; $$=addnode(3,match(s,false),$3,$5,$7); $3->arglst=copytree($7); } | LBRACK list_option RBRACK { $$=addnode(1,match(".strucval",false),$2); } | LPAR arithmetic_expr RPAR { $$=$2; } | block | IF expression THEN series ELSE series FI { $$=addnode(3,match(".if",false) ,$2,B(block_name,$4),B(block_name,$6)); } | IF expression THEN series FI { $$=addnode(2,match(".if",false),$2,B(block_name,$4)); } | WHILE expression DO series OD { $$=addwhile(match(".whilefun",false),$2,$4); } | FOR IDENT BECOMES arithmetic_expr TO arithmetic_expr DO series OD { $$=addfor($2, $4, $6, $8, match(".forint",false)); } | FOR IDENT BECOMES arithmetic_expr DOWNTO arithmetic_expr DO series OD { $$=addfor($2, $4, $6, $8, match(".downforint",false)); } | FOR IDENT IN arithmetic_expr DO series OD { $$=addfor($2, addintnode(0), $4, $6, match(".forvec",false)); } | FOR IDENT ROW arithmetic_expr DO series OD { $$=addfor($2, addvecnode(0), $4, $6, match(".format",false)); } ; var : IDENT { $$=addnode(0,$1); } | DOLLAR { $$=addnode(0,$1); } ; group : simple_group | group simple_group { $$=addnode(2,match("*",false),$1,$2); } ; simple_group : GROUPID INT { if (wronggroup($1,$2)) { Printf("Non-existent Lie group requested.\n"); YYERROR; } $$=addgroupnode($1,(index)$2); } ; function_definition : IDENT LPAR formals RPAR BECOMES series { addsym($1,$3, $6,FUNCTION); } | IDENT LPAR RPAR BECOMES series { addsym($1,NULL, $5,FUNCTION ); } | IDENT LPAR formals RPAR LBRACE series RBRACE { addsym($1,$3, $6,FUNCTION); } | IDENT LPAR RPAR LBRACE series RBRACE { addsym($1,NULL,$5,FUNCTION ); } ; formals : joined_formals | joined_formals SEMICOLON formals { symblst* p=&$1; while (*p!=NULL) p=&(*p)->next; *p=$3; $$=$1; } ; joined_formals : TYPEID varlist { assigntype(type_code(keyword[TYPEID+$1]),$2); $$=$2; } ; varlist : var { $$=$1; $$->next=NULL; } | var COMMA varlist { $$=$1; $1->next=$3; } ; list_option : { $$=NULL; } | list { --tail_pt; } ; list : expression { ++tail_pt; if (tail_pt >= TAIL_LEN) error ("Nestings of lists too deep: %d.\n",tail_pt); $$=$1; $$->next=NULL; tail[tail_pt]=$$; } | list COMMA expression { $$=$1; tail[tail_pt]->next=$3; tail[tail_pt]=$3; } ; string_opt : { $$=NULL; } | ANY_STRING ; LiE/poly.c0000644000175000017500000002126707077066014011623 0ustar hakanhakan#include "lie.h" #ifdef __STDC__ static void error_nvars(index n1,index n2); #endif static void error_nvars(index n1,index n2) { Printf("Number of variables in polynomials unequal\n"); error("( %ld <-> %ld variables).\n",(long)n1,(long)n2); } poly* Pol_from_vec(v) vector *v; { poly *result = mkpoly(1,v->ncomp); copyrow(v->compon, result->elm[0], v->ncomp); result->coef[0] = one; freemem(v); return result; } entry Degree_pol(poly* p) { entry ncols = p->ncols; entry nrows = p->nrows; entry max=MinEntry; /* will be overwritten for i==0 */ entry i,j; if (p->coef[0]->size==0) return 0; /* degree(0X[0,..,0]) set to 0 */ for (i = 0 ; i < nrows; ++i) { entry sum=0; entry* row = p->elm[i]; for (j=0 ; jmax) max = sum; } return max; } /************************************************************* * Check that a polynomial has row length r, and normalise * *************************************************************/ poly* check_pol(p,r) poly* p; entry r; { entry d = p->ncols; if (d != r) error("Number of variables in polynomial unequal Lie rank.\n"); if (!issorted(p)) return Reduce_pol(p); return p; } /* The polynomial arithmetic routines will guarantee that no improper 0 coefficients will remain, even if they were present in the arguments. */ poly* Add_pol_pol(a,b,neg_b) poly* a,* b; boolean neg_b; { return Addmul_pol_pol_bin(a,b, neg_b ? minus_one : one); } poly* Mul_bin_pol(a,b) bigint* a; poly* b; /* modifies b unless shared */ { entry nrows = b->nrows; entry i; poly* result = private_pol(b); setshared(a); for (i=0; icoef[i]=mult(a,b->coef[i]); setshared(result->coef[i]); } clrshared(a); #ifndef argumentsave freemem(a); /* don't freepol(b) since either isshared(b) or b==result */ #endif return result; } poly* Addmul_pol_pol_bin(a,b,c) poly* a,* b; bigint* c; /* a+c*b */ { index i,j,k; entry len=a->ncols; cmp_tp cmp; poly* result; if (len != b->ncols) error_nvars(len,b->ncols); if (!c->size) return a; if (issorted(a) || issorted(b)) /* then make use of this sorting: */ { cmpfn_tp compare=set_ordering(cmpfn,len,defaultgrp); if (!issorted(a)) a=Reduce_pol(a); else if (!issorted(b)) b=Reduce_pol(b); /* now both are sorted */ if (a->nrows==1 && !a->coef[0]->size) return Mul_bin_pol(c,b); if (b->nrows==1 && !b->coef[0]->size) return a; result=mkpoly(a->nrows+b->nrows,len); i=j=k=0; setshared(c); while(jnrows) { while (inrows && (cmp=compare(a->elm[i],b->elm[j],len))>0) if (!a->coef[i]->size) i++; /* skip term with 0 coefficient */ else { result->coef[k]=a->coef[i]; setshared(result->coef[k]); copyrow(a->elm[i++],result->elm[k++],len); } if (inrows && cmp==0) /* add compatible terms */ { result->coef[k]= c==one ? add(a->coef[i],b->coef[j]) : c==minus_one ? sub(a->coef[i],b->coef[j]) : add(a->coef[i],mult(c,b->coef[j])); if (!result->coef[k]->size) /* if terms cancel */ { freemem(result->coef[k]); i++; j++; } else { setshared(result->coef[k]); copyrow(a->elm[i++],result->elm[k++],len); j++; } } else /* i==a->nrows || compare(a->elm[i],b->elm[j],len)<0; */ if (!b->coef[j]->size) j++; else { result->coef[k]= c==one ? b->coef[j] : c==minus_one ? sub(null,b->coef[j]) : mult(c,b->coef[j]); setshared(result->coef[k]); copyrow(b->elm[j++],result->elm[k++],len); } } /* Now all terms of b have been included, but a may have some left */ while (inrows) if (!a->coef[i]->size) i++; else { result->coef[k]=a->coef[i]; setshared(result->coef[k]); copyrow(a->elm[i++],result->elm[k++],len); } clrshared(c); #ifndef argumentsave freepol(a); freepol(b); freemem(c); #endif if (k) { result->nrows=k; setsorted(result); return result; } freemem(result); return poly_null(len); } /* end of sorted case; if unsorted simply append polynomials and reduce */ setshared(c); result=mkpoly(a->nrows+b->nrows,len); for (i=0; inrows; i++) { result->coef[i]=a->coef[i]; setshared(result->coef[i]); copyrow(a->elm[i],result->elm[i],len); } for (j=0; jnrows; j++,i++) { result->coef[i]= c==one ? b->coef[j] : mult(b->coef[j],c); setshared(result->coef[i]); copyrow(b->elm[j],result->elm[i],len); } clrshared(c); #ifndef argumentsave freepol(a); freepol(b); freemem(c); #endif return Reduce_pol(result); } poly* Div_pol_bin(a,b) poly* a; bigint* b; { entry nrows = a->nrows; entry i; poly *result = isshared(a)? copypoly(a) : (setshared(a),a); setshared(b); for (i = 0; i < nrows; i++) { result->coef[i] = quotient(a->coef[i],b); setshared(result->coef[i]); } clrshared(b); #ifndef argumentsave freepol(a);freemem(b); #endif return result; } poly* Mod_pol_bin(a,b) poly* a; bigint* b; { entry nrows = a->nrows; entry i; poly *result = isshared(a)? copypoly(a) : (setshared(a),a); setshared(b); for (i = 0; i < nrows; i++) { result->coef[i] = mod(a->coef[i],b); setshared(result->coef[i]); } clrshared(b); #ifndef argumentsave freepol(a);freemem(b); #endif return result; } poly *Mul_pol_int(b,a) intcel *a; poly *b; { entry nrows = b->nrows, ncols = b->ncols; entry d = a->intval; entry i,j; poly *result = isshared(b)? copypoly(b) : (setshared(b),b); for (i = 0; i < nrows; i++) for (j = 0; j < ncols; j++) { result->elm[i][j] = b->elm[i][j] * d; } #ifndef argumentsave freepol(b);freemem(a); #endif return result; } poly* Div_pol_vec(b,a) poly* b; vector* a; { index nrows = b->nrows, ncols = b->ncols; entry i,j; poly* result = private_pol(b); if (ncols != a->ncomp) error("Size of vector should equal number of indeterminates.\n"); for (j=0; jcompon[j]; if (d==0) error("Division by zero.\n"); for (i=0; ielm[i][j]/=d; } return Reduce_pol(result); } poly* Mod_pol_vec(b,a) poly *b; vector *a; { index nrows = b->nrows, ncols = b->ncols; entry i,j; poly* result = private_pol(b); if (ncols != a->ncomp) error("Size of vector should equal number of indeterminates.\n"); for (j=0; jcompon[j]); if (d==0) continue; /* mod 0 is noop */ for (i=0; ielm[i][j]%=d)<0) result->elm[i][j]+=d; } } return Reduce_pol(result); } poly *Disjunct_mul_pol_pol(p1, p2) poly *p1, *p2; /*************************************************************** * Product of polynomials.De sets of free variables of p1 and p2* * are disjunct. * ***************************************************************/ { index r1= p1->ncols, r2=p2->ncols, n1=p1->nrows, n2=p2->nrows; entry **e1=p1->elm, **e2=p2->elm, **a; index i, j, s=0; poly *ans; a=(ans=mkpoly(n1*n2,r1+r2))->elm; for(i=0;icoef[s]= mult(p1->coef[i],p2->coef[j]); setshared(ans->coef[s]); s++; } #ifndef argumentsave freepol(p1); freepol(p2); #endif return(ans); } poly *Mul_pol_pol(p1,p2) poly *p1, *p2; { index ncols1 = p1->ncols, ncols2 = p2->ncols, nrows1 = p1->nrows, nrows2 = p2->nrows; index nrows = nrows1 * nrows2; poly *result, *garbage; index i,j,k = 0,l; /*************************************************************** * The wide polynomial is chosen p1 * ***************************************************************/ if (ncols1 != ncols2) error_nvars(ncols1,ncols2); garbage = result = mkpoly(nrows, ncols1); /*************************************************************** * Expand loop * ***************************************************************/ for (i=0; i < nrows1; i++) { bigint *c = p1->coef[i]; for (j=0; j < nrows2; j++) { entry *monom = result->elm[k], *monom2 = p2->elm[j]; copyrow(p1->elm[i],monom,ncols1); for (l=0; lcoef[k] = mult(c,p2->coef[j]); setshared(result->coef[k]); k++; } /* result = Reduce_pol(result); k = result->nrows; if (result != garbage) error("System warning.\n"); */ } /*************************************************************** * Sort and reduce polynomial * ***************************************************************/ result = copypoly(Reduce_pol(result)); freemem(garbage); /*************************************************************** * Freemem arguments * ***************************************************************/ #ifndef argumentsave freepol(p1); freepol(p2); #endif return result; } LiE/progs/0002775000175000017500000000000007072342154011617 5ustar hakanhakanLiE/progs/eqrank0000644000175000017500000000246606166460336013035 0ustar hakanhakan# encode simple group by unique positive number (0size(v) then return 0 # failure # fi; v=inv(v[j])*v%p; # normalise, making leading coefficient 1 # for i=1 to n_rows(m) do if i!=row_nr then m[i]=m[i]-m[i,j]*v fi od; m[row_nr]=v; 1 # success # } roots() = loc m=pos_roots; m^-m toral_dim(grp g)=Lie_rank(g[0]) ss_rank(grp g)=Lie_rank(g)-toral_dim(g) rho(grp g)=all_one(ss_rank(g))^null(toral_dim(g)) inverse(vec w)= loc l=size(w); loc wi=w; for i=1 to l do wi[i]=w[l+1-i] od; wi pos_neg(vec w)=intersection(pos_roots,W_rt_action(-pos_roots,inverse(w))) cox_mat1() = loc m=id(ss_rank); for i=1 to n_rows(m)-1 do for j=i+1 to n_rows(m) do m[i,j] = ord(W_action([i,j])); m[j,i]=m[i,j] od od; m ord(mat m) = loc p=m; loc i=1; loc idmat=id(n_rows(m)); while p!=idmat do p=p*m; i+=1 od; i cox_mat()= loc m=id(ss_rank); loc c=Cartan; for i=1 to n_rows(m)-1 do for j=i+1 to n_rows(m) do m[i,j] = 2+c[i,j]*c[j,i]; if m[i,j]==5 then m[i,j]=6 fi; m[j,i]=m[i,j] od od; m next_rewrite(vec w; int k)= { w=reduce(w); if k+1>size(w) then return w fi; loc m= cox_mat[w[k],w[k+1]]; if k+m-1>size(w) then return w fi; for i=k+2 to k+m-1 do if w[i] != w[i-2] then return w fi od; loc t=w[k+m-2]; for i=k to k+m-2 do w[i]=w[i+1] od; w[k+m-1]=t; w } all_rewrites(vec w)= { w=reduce(w); loc l=size(w); loc m=[w]; loc i=0; while i=lx do result += n_rows(level) X l; loc nl=canonical(Bruhat_desc(x,level[1])); for i=2 to n_rows(level) do nl=unique(nl^canonical(Bruhat_desc(x,level[i]))) od; level=nl; l=l-1 od; result } char_v(vec s)= loc y=rho; for i=1 to size(s) do y[s[i]]=0 od; y r_cosets(vec s)=for wt row W_orbit(char_v(s)) do print(W_word(wt)) od l_cosets(vec s)=for wt row W_orbit(char_v(s)) do print(inverse(W_word(wt))) od double_cosets(vec l,r)= for x row W_orbit(char_v(r)) do loc w=W_word(x); if w==l_reduce(l,w) then print(w) fi od inspect(grp g)= for r row id(Lie_rank(g)) do print(W_orbit_size(r,g)) od choose(grp g)= if Lie_code(g)[1]==5 then Lie_rank(g) else 1 fi semisimple(grp g)=g*Lie_group(0,-toral_dim(g)) # kill the central torus # translate(int i)=trans[i] trav(grp g; vec prefix,trans) = { loc s=ss_rank(g); if s<=3 then for r row W_orbit(rho(g),g) do action(prefix^make(translate,W_word(r,g))) od else loc c=choose(g); loc roots=id(s); loc sub_roots=roots-c; loc h=semisimple(Cartan_type(sub_roots,g)); loc new_trans=fundam(sub_roots,g)*trans; # cumul. translation # for r row W_orbit(roots[c],g) # orbit of vector with stabiliser h # do loc w=W_word(r,g); trav(h,prefix^make(translate,w),new_trans) od fi } ii(int n)=n traverse(grp g)= g=semisimple(g); trav(g,[],make(ii,ss_rank(g))) action(vec w)= print(w) # a useful initial setting # # table of Kazhdan-Lustig polynomials, most suited for B3 # str(vec w) = if w==[] then "e" else loc s=""; for i=1 to size(w) do s=s+w[i] od; s fi buf=""; first=1 output(tex t)= if length(buf+t)>70 then print(buf+","); buf=" " fi; buf = buf+ if first || buf==" " then t else ", "+t fi; first=0 flush()=if !first then print(buf+"."); first=1 fi list_KL(vec x) = { loc level=[reduce(x^long_word)]; loc l=length(level[1]); buf=str(x)+": "; while l>0 # case l=0 would not produce any output # do loc nl=null(0,l-1); for r row level do nl=unique(nl^canonical(Bruhat_desc([],r))); loc y=reduce(r^long_word); loc p=KL_poly(x,y); if p != X0 then output ( if p==X1+X0 then str(y) else if p==X2+X0 then "("+str(y)+")" else if p==X2+X1+X0 then "["+str(y)+"]" else ">"+str(y)+"<" fi fi fi ) fi od; level=nl; l+=-1 od; flush } table_KL()= { loc level=[[]]; loc l=0; while n_rows(level) do l+=1; loc nl=null(0,l); for w row level do list_KL(w); for i=1 to ss_rank do if w+i==canonical(w+i) then nl+= w+i fi od od ; level=nl od } toral(vec v) = v=v/gcd(v); loc s=size(v); (v-s)%v[s]+v[s] mk_toral(vec b; int d)= loc n=size(b); for i=2 to n-1 do b[i]=(b[i-1]+b[i])%d od; b[n]=d; b mk_toral(vec b; int d)= loc n=size(b); for i=2 to n-1 do b[i]=(b[i-1]+b[i])%d od; b[n]=d; b m=[[2,2,2,2,1,1],[0,2,2,2,1,1],[0,0,2,2,1,1], [0,0,0,2,1,1],[0,0,0,0,1,1],[0,0,0,0,-1,1]] mk_tor_d6(vec a; int d)= toral((a*m)%(2*d)+2*d) spec(pol p; vec t)= loc r=size(t); branch(p,T1,*[t-r])%[t[r]] char0(vec lambda)=Demazure(lambda) from_eps(vec lambda)=from_part(lambda)+sum(lambda) from_eps(pol p)=loc s=poly_null(n_vars(p)); for i=1 to length(p) do s+=coef(p,i) X from_eps(expon(p,i)) od; s to_eps(vec wt)= loc n=size(wt); loc v=to_part(wt-n); v+ (wt[n]-sum(v))/n * all_one(n) to_eps(pol p)=loc s=poly_null(n_vars(p)); for i=1 to length(p) do s+=coef(p,i) X to_eps(expon(p,i)) od; s char(vec lambda)=W_orbit(dom_char(lambda)) test_KL(vec x,w)= { loc result=poly_null(1); loc l=length(w); loc lx=length(x); loc dl=l-lx; loc level=[w]; while l>lx do l+=-1; loc nl=null(0,l); for y row level do result+=R_poly(x,y)*KL_poly(y,w); nl=unique(nl^canonical(Bruhat_desc(x,y))) od; level=nl od; result=={ loc pxw=KL_poly(x,w); X dl*(pxw*[[-1]])-pxw } } check_dim(vec lambda)= loc p=dom_char(Lambda); loc d=0; for i=1 to length(p) do d+=coef(p,i)*W_orbit_size(expon(p,i)) od; d==dim(lambda) chk_branch(vec wt; grp h; mat m)= dim(branch(wt,h,m),h)==dim(wt) l(vec mu)= #number of non-zero parts # loc n=size(mu); for i=1 to n do if !mu[i] then return i-1 fi od; n pleth_pol(vec lambda)= { loc p=0X0; for mu row partitions(sum(lambda)) do p+=sym_char(lambda,mu)*class_ord(mu) X l(mu) od; p } pleth_dim(vec lambda; int orig_dim)= eval_pol(pleth_pol(lambda),orig_dim)/fac(sum(lambda)) char(pol p; grp g)=W_orbit(dom_char(p,g),g) check_tensor(vec x,y)= char(tensor(x,y))==char(x)*char(y) check_branch(vec x; grp h; mat m)= char(branch(x,h,m),h)==char(x)*m check_sq(vec wt)=alt_tensor(2,wt)+sym_tensor(2,wt)==p_tensor(2,wt) chk_p_tensor(int n; vec wt)= loc d=poly_null(size(wt)); for lambda row partitions(n) do d+=n_tabl(lambda)*plethysm(lambda,wt) od; d==p_tensor(n,wt) branch_comp(vec wt; grp h; mat m; grp g)= { loc c=n_cols(m); if Lie_rank(h)!=c || Lie_rank(g)!=n_rows(m) then error("wrong size restriction matrix") fi; loc r=toral_dim(g); loc wk=null(r); loc mk=null(r,c); loc i=ss_rank(g); for j=1 to r do mk[j]=m[i+j]; wk[j]=wt[i+j] od; loc res=alt_dom(wk*mk,h); # central torus part, ensure dominant # i=0; for k=1 to comp_size(g) do r=Lie_rank(g[k]); wk=null(r); mk=null(r,c); for j=1 to r do mk[j]=m[i+j]; wk[j]=wt[i+j] od; res=tensor(res,branch(wk,h,mk,g[k]),h); i+=r od; res } branch_comp(pol p; grp h; mat m; grp g)= { loc s=coef(p,1)*branch_comp(expon(p,1),h,m,g); for i=2 to length(p) do s+=coef(p,i)*branch_comp(expon(p,i),h,m,g); od; s } shave(int i;pol p)=loc v=id(n_vars(p))[i]; filter_dom(X(-v)*p)*X v spread(pol p)=p+W_action(shave(4,p),[4])+W_action(shave(3,p),[3,4]) branch_f4_b4(pol p)=decomp(spread(dom_char(p))*m,B4) r(int a)= loc p=X[0,0]; loc sum=p; for i=1 to a do p=X[1,0]*p+X[0,i]; sum+=p od; sum s(int b)= loc p=X[b,b]; loc sum=p; for i=b-1 downto 0 do p=X[-1,0]*p+X[b,i]; sum+=p od; sum q(vec lambda)=r(lambda[1])*s(lambda[2]) p(vec lambda)= if lambda[1]>0 && lambda[2]>0 then q(lambda)-X[1,1]*q(lambda-[1,1]) else q(lambda) fi Levi_mat(int i)=fundam(id(Lie_rank)-i) # remove i-th row and renumber # Levi_type(int i)=Cartan_type(Levi_mat(i)) Levi_diagram(int i)=diagram(Levi_type(i)) Levi_res_mat(int i)= res_mat(Levi_mat(i)) Levi_branch(vec v; int i) = loc m=Levi_mat(i); branch(v,Cartan_type(m),res_mat(m)) on gc LiE/progs/maxsub0000644000175000017500000001364410305604515013040 0ustar hakanhakanoff gc #Installation file maxsub system. #This will be automatically executed during installation maxnodes 50000 read progs/maxsub0 read progs/eqrank # type A print("type A") write_string("A1,A1"+eqrank(A2),A2, "MAXSUB") write_mat(Resmat(A2,A1,1),A2,"A1.1") write_mat(Resmat(A2,A1,2),A2,"A1.2") write_string("A2,B2,A1A1"+eqrank(A3),A3, "MAXSUB") write_mat(Resmat(A3,A2),A3,"A2.1") write_mat(Resmat(A3,B2),A3,"B2.1") write_mat(Resmat(A3,A1A1),A3,"A1A1.1") write_string("A3,B2,A1A2"+eqrank(A4),A4, "MAXSUB") write_mat(Resmat(A4,A3),A4,"A3.1") write_mat(Resmat(A4,B2),A4,"B2.1") write_mat(Resmat(A4,A1A2),A4,"A1A2.1") write_string("A4,A3,C3,A2,A1A2,A1A3,A2A2"+eqrank(A5),A5 ,"MAXSUB") write_mat(Resmat(A5,A4),A5,"A4.1") write_mat(Resmat(A5,A3),A5,"A3.1") write_mat(Resmat(A5,C3),A5,"C3.1") write_mat(Resmat(A5,A2),A5,"A2.1") write_mat(Resmat(A5,A1A2),A5,"A1A2.1") write_mat(Resmat(A5,A1A3),A5,"A1A3.1") write_mat(Resmat(A5,A2A2),A5,"A2A2.1") write_string("A5,B3,A1A4,A2A3"+eqrank(A6),A6, "MAXSUB") write_mat(Resmat(A6,A5),A6,"A5.1") write_mat(Resmat(A6,B3),A6,"B3.1") write_mat(Resmat(A6,A1A4),A6,"A1A4.1") write_mat(Resmat(A6,A2A3),A6,"A2A3.1") write_string("A6,C4,D4,A1A3,A1A5,A2A4,A3A3"+eqrank(A7),A7, "MAXSUB") write_mat(Resmat(A7,A6),A7,"A6.1") write_mat(Resmat(A7,C4),A7,"C4.1") write_mat(Resmat(A7,D4),A7,"D4.1") write_mat(Resmat(A7,A1A3),A7,"A1A3.1") write_mat(Resmat(A7,A1A5),A7,"A1A5.1") write_mat(Resmat(A7,A2A4),A7,"A2A4.1") write_mat(Resmat(A7,A3A3),A7,"A3A3.1") write_string("A7,B4,A2A2,A1A6,A2A5,A3A4"+eqrank(A8),A8, "MAXSUB") write_mat(Resmat(A8,A7),A8,"A7.1") write_mat(Resmat(A8,B4),A8,"B4.1") write_mat(Resmat(A8,A2A2),A8,"A2A2.1") write_mat(Resmat(A8,A1A6),A8,"A1A6.1") write_mat(Resmat(A8,A2A5),A8,"A2A5.1") write_mat(Resmat(A8,A3A4),A8,"A3A4.1") # type B print("type B") write_string("A1"+eqrank(B2),B2, "MAXSUB") write_mat(Resmat(B2,A1),B2,"A1.1") write_string("G2"+eqrank(B3),B3, "MAXSUB") write_mat(Resmat(B3,G2),B3,"G2.1") write_string("A1,A1A1"+eqrank(B4) ,B4,"MAXSUB") write_mat(Resmat(B4,A1),B4,"A1.1") write_mat(Resmat(B4,A1A1),B4,"A1A1.1") write_string("A1"+eqrank(B5),B5, "MAXSUB") write_mat(Resmat(B5,A1),B5,"A1.1") write_string("A1"+eqrank(B6),B6, "MAXSUB") write_mat(Resmat(B6,A1),B6,"A1.1") write_string("A3,A1,A1B2"+eqrank(B7),B7, "MAXSUB") write_mat(Resmat(B7,A3),B7,"A3.1") write_mat(Resmat(B7,A1),B7,"A1.1") write_mat(Resmat(B7,A1B2),B7,"A1B2.1") write_string("A1"+eqrank(B8),B8,"MAXSUB") write_mat(Resmat(B8,A1),B8,"A1.1") # type C print("type C") write_string("A1"+eqrank(C2),C2 ,"MAXSUB") write_mat(Resmat(C2,A1),C2,"A1.1") write_string("A1,A1A1"+eqrank(C3),C3, "MAXSUB") write_mat(Resmat(C3,A1),C3,"A1.1") write_mat(Resmat(C3,A1A1),C3,"A1A1.1") write_string("A1,A1A1A1"+eqrank(C4),C4, "MAXSUB") write_mat(Resmat(C4,A1),C4,"A1.1") write_mat(Resmat(C4,A1A1A1),C4,"A1A1A1.1") write_string("A1,A1B2"+eqrank(C5),C5, "MAXSUB") write_mat(Resmat(C5,A1),C5,"A1.1") write_mat(Resmat(C5,A1B2),C5,"A1B2.1") write_string("A1,A1A3,A1B2"+eqrank(C6),C6, "MAXSUB") write_mat(Resmat(C6,A1),C6,"A1.1") write_mat(Resmat(C6,A1A3),C6,"A1A3.1") write_mat(Resmat(C6,A1B2),C6,"A1B2.1") write_string("A1,A1B3"+eqrank(C7),C7, "MAXSUB") write_mat(Resmat(C7,A1),C7,"A1.1") write_mat(Resmat(C7,A1B3),C7,"A1B3.1") write_string("B2,A1,A1D4"+eqrank(C8),C8 ,"MAXSUB") write_mat(Resmat(C8,B2),C8,"B2.1") write_mat(Resmat(C8,A1),C8,"A1.1") write_mat(Resmat(C8,A1D4),C8,"A1D4.1") # type D print("type D") write_string("A2,B2,A1A1"+eqrank(D3),D3, "MAXSUB") write_mat(Resmat(D3,A2),D3,"A2.1") write_mat(Resmat(D3,B2),D3,"B2.1") write_mat(Resmat(D3,A1A1),D3,"A1A1.1") write_string("B3,A2,A1B2"+eqrank(D4), D4, "MAXSUB") write_mat(Resmat(D4,B3),D4,"B3.1") write_mat(Resmat(D4,A2),D4,"A2.1") write_mat(Resmat(D4,A1B2),D4,"A1B2.1") write_string("B4,B2,A1B3,B2B2"+eqrank(D5),D5, "MAXSUB") write_mat(Resmat(D5,B4),D5,"B4.1") write_mat(Resmat(D5,B2),D5,"B2.1") write_mat(Resmat(D5,A1B3),D5,"A1B3.1") write_mat(Resmat(D5,B2B2),D5,"B2B2.1") write_string("B5,A1C3,A1B4,B2B3,A1A1A1"+eqrank(D6),D6, "MAXSUB") write_mat(Resmat(D6,B5),D6,"B5.1") write_mat(Resmat(D6,A1C3),D6,"A1C3.1") write_mat(Resmat(D6,A1B4),D6,"A1B4.1") write_mat(Resmat(D6,B2B3),D6,"B2B3.1") write_mat(Resmat(D6,A1A1A1),D6,"A1A1A1.1") write_string("B6,C3,B2,G2,A1B5,B2B4,B3B3"+eqrank(D7),D7, "MAXSUB") write_mat(Resmat(D7,B6),D7,"B6.1") write_mat(Resmat(D7,C3),D7,"C3.1") write_mat(Resmat(D7,B2),D7,"B2.1") write_mat(Resmat(D7,G2),D7,"G2.1") write_mat(Resmat(D7,A1B5),D7,"A1B5.1") write_mat(Resmat(D7,B2B4),D7,"B2B4.1") write_mat(Resmat(D7,B3B3),D7,"B3B3.1") write_string("B7,B4,A1C4,A1B6,B2B5,B3B4,B2B2"+eqrank(D8),D8,"MAXSUB") write_mat(Resmat(D8,B7),D8,"B7.1") write_mat(Resmat(D8,B4),D8,"B4.1") write_mat(Resmat(D8,A1C4),D8,"A1C4.1") write_mat(Resmat(D8,A1B6),D8,"A1B6.1") write_mat(Resmat(D8,B2B5),D8,"B2B5.1") write_mat(Resmat(D8,B3B4),D8,"B3B4.1") write_mat(Resmat(D8,B2B2),D8,"B2B2.1") # type E print("type E") write_string("C4,F4,A2,G2,A2G2"+eqrank(E6),E6, "MAXSUB") write_mat(Resmat(E6,C4),E6,"C4.1") write_mat(Resmat(E6,F4),E6,"F4.1") write_mat(Resmat(E6,A2),E6,"A2.1") write_mat(Resmat(E6,G2),E6,"G2.1") write_mat(Resmat(E6,A2G2),E6,"A2G2.1") write_string("A2,A1,A1,A1F4,G2C3,A1G2,A1A1"+eqrank(E7),E7, "MAXSUB") write_mat(Resmat(E7,A2),E7,"A2.1") write_mat(Resmat(E7,A1,1),E7,"A1.1") write_mat(Resmat(E7,A1,2),E7,"A1.2") write_mat(Resmat(E7,A1F4),E7,"A1F4.1") write_mat(Resmat(E7,G2C3),E7,"G2C3.1") write_mat(Resmat(E7,A1G2),E7,"A1G2.1") write_mat(Resmat(E7,A1A1),E7,"A1A1.1") write_string("G2F4,C2,A1A2,A1,A1,A1"+eqrank(E8),E8,"MAXSUB") write_mat(Resmat(E8,G2F4),E8,"G2F4.1") write_mat(Resmat(E8,C2),E8,"C2.1") write_mat(Resmat(E8,A1A2),E8,"A1A2.1") write_mat(Resmat(E8,A1,1),E8,"A1.1") write_mat(Resmat(E8,A1,2),E8,"A1.2") write_mat(Resmat(E8,A1,3),E8,"A1.3") # type F print("type F") write_string("A1,A1G2"+eqrank(F4),F4, "MAXSUB") write_mat(Resmat(F4,A1),F4,"A1.1") write_mat(Resmat(F4,A1G2),F4,"A1G2.1") # type G print("type G") write_string("A1"+eqrank(G2),G2,"MAXSUB") write_mat(Resmat(G2,A1),G2,"A1.1") print("End of installation") quit LiE/progs/maxsub00000644000175000017500000002561407101303576013123 0ustar hakanhakan# This file contains the functions |maxsub| and |resmat| defined for simple # groups of rank 2,3,..,8. # |Maxsub(g)| returns the maximal subgroups of |g|. |Resmat(g,h)| returns the # restriction matrix of |g| to the maximal subgroup |h|. If a subgroup appears # more then once, then |Resmat(g,h,i)| can be used, where |i| indicates the # |i|-th occurence of |h| as subgroup of |g|, # The following global variables are used # gp0, gp1, gp2, gp3, gp4, gp5, gp6 # rm0, rm1, rm2, rm3, rm4, rm5, rm6 # cur_group, cur_r_grp, nsubgr # The following functions are defined # e1, e2, e3, e4, e5, e6, e7, e8, e, l, issimple, # subg, show_subgroups, get_index, store_subgroups, # resm, store_restr_matrices, resmata, resmatb, resmatc, resmatd, resmatexc, # Maxsub, Resmat. off gc # this speeds up things issimple(grp g) = Lie_rank(g[0])==0 && n_comp(g)==1 # initialisation cur_group=T0 cur_r_grp=T0 nsubgr=0 gp0=T0; gp1=T0; gp2=T0; gp3=T0; gp4=T0; gp5=T0; gp6=T0 rm0=[[]]; rm1=[[]]; rm2=[[]]; rm3=[[]]; rm4=[[]]; rm5=[[]]; rm6=[[]] # storage of subgroups subg(grp g0)= { nsubgr=1; gp0=g0 } subg(grp g0,g1)= { nsubgr=2; gp0=g0; gp1=g1 } subg(grp g0,g1,g2)= { nsubgr=3; gp0=g0; gp1=g1; gp2=g2 } subg(grp g0,g1,g2,g3)= { nsubgr=4; gp0=g0; gp1=g1; gp2=g2; gp3=g3 } subg(grp g0,g1,g2,g3,g4)= { nsubgr=5; gp0=g0; gp1=g1; gp2=g2; gp3=g3; gp4=g4 } subg(grp g0,g1,g2,g3,g4,g5)= { nsubgr=6; gp0=g0; gp1=g1; gp2=g2; gp3=g3; gp4=g4; gp5=g5 } subg(grp g0,g1,g2,g3,g4,g5,g6)= { nsubgr=7; gp0=g0; gp1=g1; gp2=g2; gp3=g3; gp4=g4; gp5=g5; gp6=g6 } # retrieval of subgroups show_subgroups()= { if nsubgr>0 then print(gp0) ; if nsubgr>1 then print(gp1) ; if nsubgr>2 then print(gp2) ; if nsubgr>3 then print(gp3) ; if nsubgr>4 then print(gp4) ; if nsubgr>5 then print(gp5) ; if nsubgr>6 then print(gp6) fi fi fi fi fi fi fi } Maxsub(grp g)= { if !issimple(g) then error("Maxsub only available for simple groups") fi ; if Lie_rank(g)<2 || Lie_rank(g)>8 then error("Maximal subgroups available only for rank=2,3,..,8.") fi ; if !g==cur_group then store_subgroups(g) fi ; show_subgroups } # get group at index i Maxsub(int i)= { if i==1 then return gp0 fi ; if i==2 then return gp1 fi ; if i==3 then return gp2 fi ; if i==4 then return gp3 fi ; if i==5 then return gp4 fi ; if i==6 then return gp5 fi ; if i==7 then return gp6 fi ; T0 } # storage of restriction matrices resm(mat m0)= { rm0=*m0 } resm(mat m0,m1)= { rm0=*m0; rm1=*m1 } resm(mat m0,m1,m2)= { rm0=*m0; rm1=*m1; rm2=*m2 } resm(mat m0,m1,m2,m3)= { rm0=*m0; rm1=*m1; rm2=*m2; rm3=*m3 } resm(mat m0,m1,m2,m3,m4)= { rm0=*m0; rm1=*m1; rm2=*m2; rm3=*m3; rm4=*m4 } resm(mat m0,m1,m2,m3,m4,m5)= { rm0=*m0; rm1=*m1; rm2=*m2; rm3=*m3; rm4=*m4; rm5=*m5 } resm(mat m0,m1,m2,m3,m4,m5,m6)= { rm0=*m0; rm1=*m1; rm2=*m2; rm3=*m3; rm4=*m4; rm5=*m5; rm6=*m6 } # retrieval of restriction matrices resm(int n)= { if n==1 then rm0 else if n==2 then rm1 else if n==3 then rm2 else if n==4 then rm3 else if n==5 then rm4 else if n==6 then rm5 else if n==7 then rm6 else null(0,0) # default case needed for type consistency fi fi fi fi fi fi fi } # get index of |i|-th group equal to |h| on stack get_index(grp h; int i)= { for j=1 to nsubgr do if h==Maxsub(j) then i=i-1 ; if i==0 then return j fi fi od ; 0 } Resmat(grp g,h;int k)= { if !issimple(g) then error("Resmat only available for simple groups.") fi ; if Lie_rank(g)<2 || Lie_rank(g)>8 then error("Resmat only available for rank=2,3,..8.") fi ; if !g==cur_group then store_subgroups(g) fi ; loc i=get_index(h,k) ; if i==0 then error("Not available as maximal subgroup") fi ; if !g==cur_r_grp then store_restr_matrices(g) fi ; resm(i) } Resmat(grp g,h)=Resmat(g,h,1) store_subgroups(grp g)= { cur_group=g ; if Lie_code(g)[1]<5 then if Lie_code(g)[1]==1 then if Lie_rank(g)==2 then subg(A1,A1) fi ; if Lie_rank(g)==3 then subg(A2,B2,A1A1) fi ; if Lie_rank(g)==4 then subg(A3,B2,A1A2) fi ; if Lie_rank(g)==5 then subg(A4,A3,C3,A2,A1A2,A1A3,A2A2) fi ; if Lie_rank(g)==6 then subg(A5,B3,A1A4,A2A3) fi ; if Lie_rank(g)==7 then subg(A6,C4,D4,A1A3,A1A5,A2A4,A3A3) fi ; if Lie_rank(g)==8 then subg(A7,B4,A2A2,A1A6,A2A5,A3A4) fi fi ; if Lie_code(g)[1]==2 then if Lie_rank(g)==2 then subg(A1) fi ; if Lie_rank(g)==3 then subg(G2) fi ; if Lie_rank(g)==4 then subg(A1,A1A1) fi ; if Lie_rank(g)==5 then subg(A1) fi ; if Lie_rank(g)==6 then subg(A1) fi ; if Lie_rank(g)==7 then subg(A3,A1,A1B2) fi ; if Lie_rank(g)==8 then subg(A1) fi fi ; if Lie_code(g)[1]==3 then if Lie_rank(g)==2 then subg(A1) fi ; if Lie_rank(g)==3 then subg(A1,A1A1) fi ; if Lie_rank(g)==4 then subg(A1,A1A1A1) fi ; if Lie_rank(g)==5 then subg(A1,A1B2) fi ; if Lie_rank(g)==6 then subg(A1,A1A3,A1B2) fi ; if Lie_rank(g)==7 then subg(A1,A1B3) fi ; if Lie_rank(g)==8 then subg(B2,A1,A1D4) fi fi ; if Lie_code(g)[1]==4 then if Lie_rank(g)==3 then subg(A2,B2,A1A1) fi ; if Lie_rank(g)==4 then subg(B3,A2,A1B2) fi ; if Lie_rank(g)==5 then subg(B4,B2,A1B3,B2B2) fi ; if Lie_rank(g)==6 then subg(B5,A1C3,A1B4,B2B3,A1A1A1) fi ; if Lie_rank(g)==7 then subg(B6,C3,B2,G2,A1B5,B2B4,B3B3) fi ; if Lie_rank(g)==8 then subg(B7,B4,A1C4,A1B6,B2B5,B3B4,B2B2) fi fi else # Lie_code(g)[1]>=5 if g==E6 then subg(C4,F4,A2,G2,A2G2) fi ; if g==E7 then subg(A2,A1,A1,A1F4,G2C3,A1G2,A1A1) fi ; if g==E8 then subg(G2F4,C2,A1A2,A1,A1,A1) fi ; if g==F4 then subg(A1,A1G2) fi ; if g==G2 then subg(A1) fi fi } l()=Lie_rank(cur_r_grp) e(int i)= { loc t=null(l); t[i]=1; t } e1()=e(1) e2()=e(2) e3()=e(3) e4()=e(4) e5()=e(5) e6()=e(6) e7()=e(7) e8()=e(8) store_restr_matrices(grp g)= { cur_r_grp=g ; if Lie_code(g)[1]<5 then if Lie_code(g)[1]==1 then resmata fi ; if Lie_code(g)[1]==2 then resmatb fi ; if Lie_code(g)[1]==3 then resmatc fi ; if Lie_code(g)[1]==4 then resmatd fi else resmatexc fi } resmata()= { if Lie_rank(g)==2 then resm([[1,1]],[[2,0]]) fi ; if Lie_rank(g)==3 then resm([e1+e2,e3],[e2,e1+e3],[e1+e3,[1,2,1]]) fi ; if Lie_rank(g)==4 then resm([e1,e2+e3,e4],[e1+e4,2*(e2+e3)],[e2+e3,e1+e2,e3+e4]) fi ; if Lie_rank(g)==5 then resm([e1,e2,e3+e4,e5] ,[e2+e4,e1+e5,e2+2*e3+e4] ,[e1+e5,e2+e4,e3] ,[[0,1,3,2,2],[2,2,0,1,0]] ,[[1,0,1,0,1],[1,2,1,0,0],[0,0,1,2,1]] ,[e3,e1,e2+e3+e4,e5] ,[e2,e3+e4,e1+e2+e3,e4+e5] ) fi ; if Lie_rank(g)==6 then resm([e1,e2,e3+e4,e5,e6] ,[e1+e6,e2+e5,2*(e3+e4)] ,[e3+e4,e1,e2+e3,e4+e5,e6] ,[e2+e3,e4+e5,e1+e2,e3+e4,e5+e6] ) fi ; if Lie_rank(g)==7 then resm([e1,e2,e3,e4+e5,e6,e7] ,[e1+e7,e2+e6,e3+e5,e4] ,[e1+e7,e2+e6,e3+e5,e3+2*e4+e5] ,[e1+e3+e5+e7,e1+2*e2+e3,e3+2*e4+e5,e5+2*e6+e7] ,[e4,e1,e2,e3+e4+e5,e6,e7] ,[e3+e4,e5,e1,e2+e3,e4+e5+e6,e7] ,[e2+e3,e4,e5+e6,e1+e2,e3+e4+e5,e6+e7] ) fi ; if Lie_rank(g)==8 then resm([e1,e2,e3,e4+e5,e6,e7,e8] ,[e1+e8,e2+e7,e3+e6,2*(e4+e5)] ,[[1,0,1,1,0,1,1,0] ,[0,1,1,0,1,1,0,1] ,[1,2,1,2,1,1,0,0] ,[0,0,1,1,2,1,2,1] ] ,[e4+e5,e1,e2,e3+e4,e5+e6,e7,e8] ,[e3+e4,e5+e6,e1,e2+e3,e4+e5,e6+e7,e8] ,[e2+e3,e4+e5,e6+e7,e1+e2,e3+e4,e5+e6,e7+e8] ) fi } resmatb()= { if Lie_rank(g)==2 then resm([[4,3]]) fi ; if Lie_rank(g)==3 then resm([e1+e3,e2]) fi ; if Lie_rank(g)==4 then resm([[8,14,18,10]], [[2,2,4,1],[2,4,4,3]]) fi ; if Lie_rank(g)==5 then resm([[10,18,24,28,15]]) fi ; if Lie_rank(g)==6 then resm([[12,22,30,36,40,21]]) fi ; if Lie_rank(g)==7 then resm([[1,0,1,1,0,2,1],[0,1,2,1,3,2,1],[1,2,1,3,2,2,1]] ,[[14,26,36,44,50,54,28]] ,[[2,2,4,2,2,4,1],[1,2,1,2,1,1,0],[0,0,2,2,4,4,3]] ) fi ; if Lie_rank(g)==8 then resm([[16,30,42,52,60,66,70,36]]) fi } resmatc()= { if Lie_rank(g)==2 then resm([[3,4]]) fi ; if Lie_rank(g)==3 then resm([[5,8,9]], [[1,0,1],[2,4,4]]) fi ; if Lie_rank(g)==4 then resm([[7,12,15,16]], [[1,0,1,2],[1,2,1,2],[1,2,3,2]]) fi ; if Lie_rank(g)==5 then resm([[9,16,21,24,25]], [[1,0,1,0,1],[1,2,1,0,0],[0,0,2,4,4]]) fi ; if Lie_rank(g)==6 then resm([[11,20,27,32,35,36]] ,[[1,0,1,0,1,2],[0,0,1,2,1,2],[1,2,1,0,0,0],[0,0,1,2,3,2]] ,[[2,2,4,2,2,4],[0,0,1,1,2,1],[1,2,1,2,1,2]] ) fi ; if Lie_rank(g)==7 then resm([[13,24,33,40,45,48,49]] ,[[1,0,1,0,1,0,1],[1,2,1,0,0,0,0],[0,0,1,2,1,0,0],[0,0,0,0,2,4,4]] ) fi ; if Lie_rank(g)==8 then resm([[1,0,2,2,2,0,1,2],[1,4,3,4,5,8,7,6]] ,[[15,28,39,48,55,60,63,64]] ,[[1,0,1,0,1,0,1,2] ,[1,2,1,0,0,0,0,0] ,[0,0,1,2,1,0,0,0] ,[0,0,0,0,1,2,1,2] ,[0,0,0,0,1,2,3,2] ] ) fi } resmatd()= { if Lie_rank(g)==3 then resm([e2+e1,e3],[e1,e2+e3],[e2+e3,[2,1,1]]) fi ; if Lie_rank(g)==4 then resm([e4,e2,e1+e3] ,[[1,0,1,1],[1,3,1,1]] ,[[1,2,0,1],[0,1,1,0],[1,0,0,1]] ) fi ; if Lie_rank(g)==5 then resm([e1,e2,e3,e4+e5] ,[[0,1,0,1,1],[2,2,4,1,1]] ,[e4+e5,e1,e2,e3+e3+e4+e5] ,[e1,[0,2,2,1,1],e3,e4+e5] ) fi ; if Lie_rank(g)==6 then resm([e1,e2,e3,e4,e5+e6] ,[e1+2*e2+e3+2*e4+e6,e1+e3+e4,e2+e3+e6,e4+e5] ,[e5+e6,e1,e2,e3,2*e4+e5+e6] ,[e3+e4,e5+e6,e1,e2+e3,e4+e4+e5+e6] ,[[2,4,6,6,4,4],[1,2,1,2,0,1],[1,0,1,2,1,0]] ) fi ; if Lie_rank(g)==7 then resm([e1,e2,e3,e4,e5,e6+e7] ,[[0,1,0,1,0,1,1],[1,0,0,1,3,1,1],[0,1,2,1,0,0,0]] ,[[2,2,3,1,3,1,1],[0,2,2,6,4,3,3]] ,[[0,3,4,3,5,1,1],[1,0,0,1,0,1,1]] ,[e6+e7,e1,e2,e3,e4,e5+e5+e6+e7] ,[e4+e5,e6+e7,e1,e2,e3+e4,e5+e5+e6+e7] ,[e1+e2,e3+e4,e5+e5+e6+e7,e2+e3,e4+e5,e6+e7] ) fi ; if Lie_rank(g)==8 then resm([e1,e2,e3,e4,e5,e6,e7+e8] ,[e4+e5+e7,e3+e5+e6,e2+e8,e1+e3+2*e4+e5+2*e6+e7] ,[e1+2*e2+e3+2*e4+e5+2*e6+e8,e1+e3+e4,e2+e3+e5+e6,e4+e5+e8,e6+e7] ,[e7+e8,e1,e2,e3,e4,e5,e6+e6+e7+e8] ,[e5+e6,e7+e8,e1,e2,e3,e4+e5,e6+e6+e7+e8] ,[e3+e4,e5+e6,e7+e8,e1,e2+e3,e4+e5,e6+e6+e7+e8] ,[[0,0,1,1,2,1,0,1] ,[1,2,1,2,1,2,2,1] ,[0,1,1,0,1,1,1,0] ,[1,0,1,2,1,2,0,1] ] ) fi } resmatexc()= { if cur_r_grp==E6 then resm([e3+e5,e1+e6,e3+2*e4+e5,e2] ,[e2,e4,e3+e5,e1+e6] ,[[2,1,2,5,5,2],[2,4,5,5,2,2]] ,[[2,1,2,5,2,2],[0,1,1,0,1,0]] ,[e1+e2+2*e3+e4,e2+e4+2*e5+e6,e1+e2+e4+e6,e3+e4+e5] ) fi ; if cur_r_grp==E7 then resm([[4,7,9,11,10,6,6],[4,4,6,11,7,6,0]] ,[[34,49,66,96,75,52,27]] ,[[26,37,50,72,57,40,21]] ,[[0,1,0,2,1,2,1],e1,e3+e4,e5+e6+e2,e4+e5+e7] ,[[1,0,2,1,1,2,1] ,[0,1,0,1,1,0,0] ,[0,0,1,1,1,0,1] ,[1,0,0,1,1,1,0] ,[0,1,1,1,0,0,0] ] ,[[2,3,4,4,5,4,1],[2,1,2,4,4,1,0],[0,1,1,1,0,1,1]] ,[[4,8,10,18,12,8,6],[6,7,10,12,11,8,3]] ) fi ; if cur_r_grp==E8 then resm([[1,0,2,1,1,2,1,1] ,[0,1,0,1,1,0,0,0] ,[0,0,0,0,1,1,1,0] ,[0,1,1,1,0,0,0,0] ,[1,0,0,1,1,1,0,0] ,[0,0,1,1,1,0,1,1] ] ,[[4,6,8,16,12,8,8,2],[4,6,8,9,8,7,3,3]] ,[[8,12,16,22,16,14,10,6],[2,3,4,8,6,4,4,1],[2,3,4,5,6,4,1,1]] ,[[72,106,142,210,172,132,90,46]] ,[[60,88,118,174,142,108,74,38]] ,[[92,136,182,270,220,168,114,58]] ) fi ; if cur_r_grp==F4 then resm([[22,42,30,16]], [[4,4,4,2],[1,1,0,1],[0,1,1,0]]) fi ; if cur_r_grp==G2 then resm([[6,10]]) fi } on gc LiE/progs/test0000644000175000017500000000415305354345047012525 0ustar hakanhakany=1 f(int x)=x=x+1;y=5 x=10 f(1) if y==5 then print("1 Okay") fi if x==10 then print("2 Okay") fi x=[1,2] y=x y[2]=3 if x==[1,2] then print("3 Okay") fi if y==[1,3] then print("4 Okay") fi f(vec x)=x[2]=100;if x==[1,100] then \ print("5 Okay") fi y=[1,2] f(y) if y==[1,2] then print("6 Okay") fi i=100 x=99 for i=1 to 10 do if i==5 then x=25 fi od if i==100 then print("7 Okay") fi if x==25 then print("8 Okay") fi f() = for i=1 to 10 do if i==5 then loc x=75 fi od;\ if x==99 then print("9 Okay") fi x=99 f() if x==99 then print("10 Okay") fi if for i=1 to 1 do i od == 1 then print("11 Okay") else\ print("11 False") fi a=0 for i=1 to 10 do if i==5 then a=i fi od;\ if a==5 then print("12 Okay") else print("12 false") fi #k=7 #l=0 #l = for i=1 to k do i od #if (nref(k)==1 && nref(l)==1 && l==k) then \ #print("13 Okay") else print("13 false") fi y=[2,3] g()=if y==10 then print("14 Okay") else print("14 false") fi f(int y)=g() f(10) #g()=if nref(3) == 1 then print("15 Okay") else print("15 false");print(nref(3)) fi #g if {loc m=null(0,2);for i=1 to 2 do for j=1 to 2 do m=m+[i,j] od od;m} \ == [[1,1],[1,2],[2,1],[2,2]] \ then print("16 Okay") \ else print("16 false") fi k=0;if for i=1 to 10 do \ i=1;k=k+1; \ if k==3 then break(i) \ else i fi od\ ==1 then print("17 Okay") else print("17 false") fi f()=loc x = [1,2];x g()=loc x=3;f if g == [1,2] then print("18 Okay") else print("18 false") fi f(int x)=loc x=x+1;x if f(3)==4 then print("19 Okay") else print("19 false") fi q(int x)=if x>1 then loc c=q(x-1)+1;c else 1 fi if q(2)==2 then print("20 Okay") else print("20 false") fi f(int x)=if x!=0 then return 1 + f(x-1) fi;1 g(int x)=if x==0 then return 1 fi; 1 + g(x-1) h(int x)=if x==0 then 1 else 1 + h(x-1) fi if f(3)==4 then print("21 Okay") else print("21 false") fi if g(3)==4 then print("22 Okay") else print("22 false") fi if h(3)==4 then print("23 Okay") else print("23 false") fi f()=p[1]=7;p g()=p[2]=3;p p=[0,0] p= f()+g() if p == [14,3] then print("24 Okay") else print ("24 False") fi f(int x)=loc a=1;if x==0 then a = f(x-1) fi;a if (f(3)==1) then print("25 Okay") else print("25 False") fi LiE/progs/test00000644000175000017500000000305106166473712012604 0ustar hakanhakanprint("Testing integer arithmetic") er(int i)=print("Error (in integer arithmetic) no:");print(i);print("") if 123456789123456789+876543210876543211!=10^18 then er(1) fi if 987654321987654321-876543210876543210!=11*(101*10001*100000001*100+1) then er(2) fi if 123456789987654321%34567899876543+ 34567899876543*(123456789987654321/34567899876543)!= 123456789987654321 then er(3) fi print("Testing vector arithmetic") er(int i)=print("Error (in vector arithmetic) no:");print(i);print("") if !([]+[]==[]) then er(1) fi if !([654321,-76543,0]+[123456,65432,-12345]==[777777,-11111,-12345]) then er(2) fi if !([123,456,-789]^[234]-[122,457,-789,-1]==(1+[-1,10,0]+235-3)) then er(3) fi if !([123,484]%44+44*([123,484]/44)==[123,484]) then er(4) fi print("Testing matrix arithmetic") er(int i)=print("Error (in matrix arithmetic) no:");print(i);print("") if !([[]]+[[]]==**[[]]) then er(1) fi if !([[(87654321+1),-87654321]]*[[ 87654321+1],[87654321]]== [[2* 87654321+1]]) then er(2) fi if !([[1,0],[-100,1]]+[[0,100],[100,0]]==[[1,1],[0,1]]^100) then er(3) fi if !([[123],[456]]%44+44*( [[123],[456]]/44)==[[123],[456]]) then er(4) fi if !([[1,0,-1]]+[1,1,0]==[[1,-1,0],[0,0,1]]*[[3,-10,7],[2,-10,8],[1,1,0]]) then er(5) fi print("Testing matrix/vector arithmetic") er(int i)=print("Error (in matrix/vector arithmetic) no:");print(i);print("") if !([[]]**[[]]==[[0]]) then er(1) fi if !([[12,-13],[1,0],[-19,-1]]*[10,4]==[10,4]*(* [[12,-13],[1,0],[-19,-1]])) then er(2) fi if !([[10,-10,3,0]]*(*[[9,8,-7,-6]])==[[[10,-10,3,0]*[9,8,-7,-6]]]) then er(3) fi LiE/progs/test10000644000175000017500000002520306167211435012601 0ustar hakanhakanprint("Testing function calls:") print("abs") abs(-1) abs(0) abs(1) abs(123456789123456789123456789) abs(-123456789123456789123456789) print("Adams") Adams(1,[1],A1) Adams(2,[1],A1) Adams(3,[1],A1) Adams(2,[0,0,0,1],F4) setdefault(E6) Adams(2,[1,0,0,0,0,0]) Adams(1,[1],T1) print("adjoint") adjoint(A1) adjoint(A2) setdefault(E6) adjoint adjoint(G2) adjoint(T2) print("alt_tensor") alt_tensor(1,[1,0],A2) alt_tensor(2,[0,1],A2) setdefault(A2) alt_tensor(3,[1,0]) alt_tensor(4,[1,0]) alt_tensor(4,[2],A1) alt_tensor(0,[1],A1) alt_tensor(2,[1,0,0,0],A2A2) print("branch") branch([1,0],A1,[[0],[1]],A2) branch([0,1],A2,[[1,0],[1,1]],G2) setdefault(D4) branch([1,1,0,0],A1A1A1A1,[[1,1,0,0],[1,1,1,1],[0,1,1,0],[0,1,0,1]]) setdefault(F4) branch([1,0,0,0],A1G2,[[4,1,0],[4,1,1],[4,0,1],[2,1,0]]) branch([1],T1,[[1]],A1) branch([1,1],T2,id(2),G2) print("break") v=null(3) for i=0 to 3 do for j=1 to 5 do for k=-18 to -16 do if k==-17 then v[3]={ break(k) } fi; 0 od ; if j==2 then v[2]={ break(j) } fi; 0 od ; if i==2 then v[1]={ break(i) } fi; 0 od; v print("Cartan") Cartan(G2) Cartan(T3) Cartan(A2E8G2) setdefault(A2) Cartan Cartan(A1) Cartan(T0) setdefault(T3A2T2F4) Cartan Cartan([1],[1],A1) setdefault(G2E6) Cartan([1,0,1,0,0,0,0,0],[0,0,1,0,0,0,0,0]) Cartan([1,1,1,1],[0,1,2,2],A1B3T2) print("Cartan_type") Cartan_type([[1,2,2,3,2,1],[0,1,0,0,0,0]],E6) setdefault(D4) Cartan_type([[1,0,0,0],[0,0,1,0],[0,0,0,1],[1,2,1,1]]) Cartan_type(null(0,0),T1) print("center") center(A1) center(A2) setdefault(E8) center center(D6) center(T3) print("cent_roots") cent_roots([1,2,3,4,4],A4) setdefault(G2) cent_roots([1,2,2]) cent_roots([1,3],A1) cent_roots([[2,2,3,3,5],[1,2,3,3,4]],A4) setdefault(F4) cent_roots([[1,3,2,5,3],[1,3,2,1,4]]) print("centr_type") centr_type([1,2,3,3],A3) centr_type([[1,2,3,3]],A3) setdefault(A4) centr_type([1,2,3,4,4]) setdefault(A2) centr_type([[1,2,2]]) centr_type([[1,3,2,5,3],[1,3,2,1,4]],F4) print("collect") collect(X[1,0]+X[0,1]+X[0,0],A2,[[1,0],[-1,1]],G2) setdefault(A1) collect(X[0]+2X[1]+X[2],A1,[[1]]) collect(branch([1,1],T2,id(2),G2),T2,id(2),G2) print("n_cols") n_cols([[]]) n_cols(null(2,0)) n_cols(null(0,3)) n_cols([[1,-100,2],[2,-1,0]]) print("n_comp") n_comp(T0) n_comp(T5) n_comp(A3) n_comp(T6A1B2C3D4E6E7E8G2A1A1) setdefault(A1G2G2F4G2G2A1) n_comp print("contragr") contragr([],T0) contragr([1],T1) contragr([1,0],A2) setdefault(B3) contragr([1,0,0]) print("decomp") decomp(3X[0]+4X[1]+2X[2]+1X[3]+2X[4],A1) setdefault(F4) decomp(2X[1,0,0,0]+3X[0,0,0,1]+10X[0,0,0,0]) setdefault(B3G2) decomp(X[1,0,0,0,0]+X[0,1,0,0,0]+X[0,0,0,1,0]+X[0,0,0,0,1]+5X[0,0,0,0,0]) decomp(0X[0],A1) v_decomp(-X[0],A1) decomp(0X[-1],A1) decomp(dom_char([3,1],G2),G2) print("dim") dim([0,1,0],B3) setdefault(E8) dim([0,0,1,0,0,0,0,0]) setdefault(G2F4G2) dim([0,0,0,0,0,1,1,0]) setdefault(G2F4G2T2) dim([0,0,0,0,0,1,1,0,234,-19]) print("det_Cartan") det_Cartan(T0) det_Cartan(T3) det_Cartan(A1) det_Cartan(G2F4) setdefault(E6) det_Cartan print("diag") diag(null(0,0)) diag([[1]]) diag([[1,1]]) diag([[]]) diag([[1,2],[3,4],[5,6]]) print("diagram") diagram(T0) diagram(T3) diagram(A1) setdefault(B4) diagram diagram(A2D4F4G2) setdefault(E8E8) diagram print("dim") dim(A1) dim(T5) dim(E8) dim(T1A1G2T1) setdefault(T1A2E8E8) dim print("dominant") dominant([0,0],G2) dominant([-3,2],A1A1) setdefault(F4E6) dominant([-2,1,0,0,0,0,1,2,-1,0]) dominant([-1,-1,-1,-1,-1,-1,-10,100],T1E6T1) print("dom_weights") dom_weights([0],A1) dom_weights([1],A1) dom_weights([2],A1) setdefault(E8) dom_weights(1+null(7)) dom_weights([1],T1) print("eval") eval(print("eval")) print("exponents") exponents(A4) setdefault(E8) exponents exponents(T0A3D4T5G2) print("factor") factor(0) factor(-1) factor(1) factor(123456789) print("fundam") fundam(null(0,1),A1) fundam([[1,0],[0,1],[1,1]],A2) setdefault(B2) fundam([[1,0],[1,1]]) fundam([[1,0],[0,1]],A1A1) fundam(null(0,0),T0) fundam([[1,1,0],[0,0,1]],D3T3) print("high_root") high_root(A1T1) setdefault(E8) high_root high_root(F4) print("i_Cartan") i_Cartan(T0) i_Cartan(T3) i_Cartan(E7) setdefault(F4) i_Cartan i_Cartan(D4G2B3) print("inprod") inprod([],[],T2) setdefault(A2) inprod([1,2],[2,1]) m=i_Cartan(F4) for i=1 to 4 do for j=1 to 4 do print(inprod(m[i],m[j],F4)) od od inprod([2,1,1,2],[3,2,2,1],G2A2T1) print("length") length([],T0) length([],T4) length([1],A1) length([2,2],A4) length([1,2],A2T2) length([1,2,1,2,1,2],A2T2) setdefault(C3) length([1,2,3,1]) length([1,4,6,9],E7G2) print("Lie_code") Lie_code(T0) Lie_code(D5) setdefault(G2) Lie_code print("Lie_group") Lie_group(0,0) Lie_group(2,2) Lie_group(3,2) Lie_group(6,4) print("Lie_rank") Lie_rank(C5) setdefault(E6) Lie_rank Lie_rank(T0) Lie_rank(A2T2D4F4G2E8T100) print("long_word") long_word(T0) long_word(T3) long_word(A1) setdefault(F4) long_word long_word(F4G2T3) print("l_reduce") l_reduce([2],[1,2,1],A2) l_reduce([],[1,2,1],A2) setdefault(A3A3) l_reduce([1,4],[1,2,3,2,1,3,4,5,6,5,4,6]) l_reduce([1,5],[1,2,3,2,1,3,5,6,7,6,5,7],A7) l_reduce([4,5],[1,2,3,6,3,4],A2G2C2T6) print("lr_reduce") lr_reduce([1],[1,2,3],[3],D3) setdefault(G2A2T5F4A1) lr_reduce([2,5,3,9],[2,5,3,9,1,2,4,2,7,6,4,9,8,3,4,7,2],[1]) lr_reduce([],[],[],T7) lr_reduce([],[1,2,1],[],A2) print("mat_vec") mat_vec(null(0),1) mat_vec(null(1),1) mat_vec([1,2,3,4,5,6],1) mat_vec([1,2,3,4,5,6],2) mat_vec([1,2,3,4,5,6],3) mat_vec([1,2,3,4,5,6],6) print("dom_char") dom_char([2],A1) setdefault(F4) dom_char([1,0,0,0]) dom_char([0,1,1,0],G2G2) dom_char([1,1,1,1,1,1,1,1,1,1,1,1,1],A1A1A1A1A1A1A1A1A1A1A1A1A1) dom_char([],[],T0) setdefault(G2) dom_char([2,2],[1,0]) dom_char([1,2,10],G2T1) dom_char([1,2,10],[1,1,10],G2T1) print("next_part") next_part([3,1,1,1,0,0]) next_part([3]) next_part([1,1,1]) next_part([]) print("next_perm") next_perm([]) next_perm([0]) next_perm([0,0,0]) next_perm([3,2,1]) next_perm([-10,4,4,10,-10]) print("norm") norm([2,1],B2) setdefault(B2) norm([1,0]) norm([1,1],A1A1) norm([1,1],G2T1) print("n_pos_roots") n_pos_roots(T0) n_pos_roots(T3) n_pos_roots(B3) setdefault(E7) n_pos_roots n_pos_roots(C3D4) n_pos_roots(C3D4T5) print("orbit") orbit(50,[1],[[2]]) orbit([1,0],[[0,1],[-1,0]]) orbit([0,1,0],[[0,-1,0],[1,0,0],[0,0,0],[0,0,0],[0,0,-1],[0,1,0]]) print("partitions") partitions(4) partitions(0) print("plethysm") plethysm([2],[1],A1) plethysm([1,1],[1],A1) setdefault(A2) plethysm([2,1],[1,0]) plethysm([3,2],[1,0,0],A3) print("pos_roots") pos_roots(T0) pos_roots(T3) pos_roots(G2) setdefault(E6) pos_roots pos_roots(A2B2) print("p_tensor") p_tensor(3,[1,0,0],A3) setdefault(B2) p_tensor(2,[1,1]) p_tensor(2,2X[0,0,0]+X[1,0,0],C3) setdefault(G2) p_tensor(2,2X[0,0]+X[1,0]) p_tensor(2,[1,1],A1A1) setdefault(A1A2) p_tensor(2,X[0,1,1]+X[1,0,1]) print("reduce") reduce([1,2,1,2,1],A2) reduce([],T1) setdefault(G2F4T100) reduce([1,3,2,4,1,3,2,4,2,3,1,4,2,3,6,5,6,5,1]) print("reflection") reflection([1,0],A2) setdefault(G2) reflection([1,0]) reflection([1,0],A1A1) print("n_rows") n_rows([[]]) n_rows([[1,2,3],[4,5,6]]) n_rows(null(5,0)) print("r_reduce") r_reduce([1,2,1],[2],A2) r_reduce([1,2,1],[],A2) setdefault(A3A3) r_reduce([6,4,5,6,5,4,3,1,2,3,2,1],[4,1]) r_reduce([7,5,6,7,6,5,3,1,2,3,2,1],[1,5],A7) r_reduce([4,3,6,3,2,1],[4,5],C2G2A2T6) print("setdefault") setdefault(B2A1T1A1) setdefault print("size") size([]) size([1,2,3,4]) print("sort") sort([]) sort([1]) sort([2,1]) sort([5,5,3,2,3,1,2,5]) sort([[]]) sort([[1,3,2],[1,3,2],[3,1,2],[2,1,3],[3,2,1],[1,3,2]]) sort(null(3,0)) sort(null(0,3)) print("spectrum") spectrum(X[1],[1,3],A1) setdefault(G2) spectrum([1,1],[1,0,3]) spectrum([1,1],[1,0,3],A1A1) spectrum([0,0,0,0],[6,2,8,3,19],F4) print("sym_char") sym_char([]) sym_char([1]) sym_char([1,1]) sym_char([2]) sym_char([3,2,1]) sym_char([1,0]) sym_char([3,1,1]) print("sym_orbit") sym_orbit([]) sym_orbit([1,2,1,2]) sym_orbit([1,1,1,1,1,1,1,2]) print("sym_tensor") sym_tensor(1,[],T0) sym_tensor(1,[1,0,0,0,0,0,0,0],E8) setdefault(F4) sym_tensor(2,[0,1,0,0]) sym_tensor(3,[1,0],A2) setdefault(C3) sym_tensor(4,[0,1,0]) sym_tensor(2,2X[0,0]+X[0,1],G2) setdefault(G2) sym_tensor(2,2X[0,0]+X[0,1]) sym_tensor(2,X[1,0]+X[0,1],A1A1) print("tensor") tensor([],[],T0) tensor([11],[18],A1) setdefault(B4) tensor([1,0,1,0],[0,0,1,2]) tensor([1,0],[0,1],G2) setdefault(A3) tensor([1,0,0],[0,1,0]) setdefault(F4) tensor(10X[1,0,0,0]-5X[0,1,0,0],5X[0,0,0,0]+3X[0,0,0,1]) tensor(2X[0,0,1]+X[0,1,2],-X[0,0,3]+3X[1,0,1]+X[1,1,0],B3) setdefault(C3) tensor(2X[0,0,1]+X[0,1,2],-X[0,0,3]+3X[1,0,1]+X[1,1,0]) tensor(X[0,0]+2X[0,1],3X[0,0]+X[1,0]+0X[1,1],B2) tensor(4X[0,0]+X[1,0],X[1,0]+X[0,1],A1A1) tensor(0X[0,0]+2X[1,0]-X[0,1],X[1,1]-X[2,1]+X[1,1],A2) tensor([1,1],[0,2],[1,0],G2) setdefault(E6) tensor([1,1,0,0,0,0],[0,0,0,1,0,0],[1,0,0,1,0,0]) print("v_decomp") v_decomp(X[3,0,0]+2X[2,1,0]+X[2,0,1]+8X[2,0,0]+2X[1,2,0]+ X[1,1,1]-5X[1,1,0]+2X[1,0,2]+6X[1,0,1]-21X[1,0,0]+2X[0,2,1]+ 4X[0,2,0]+12X[0,1,0]+2X[0,0,3]+2X[0,0,2]-11X[0,0,1]+16X[0,0,0],C3) setdefault(A1) v_decomp(-2X[2]+X[1]-2X[0]) print("vec_mat") vec_mat(null(0,0)) vec_mat(null(2,0)) vec_mat(null(0,2)) vec_mat(null(2,2)) vec_mat([[1,2,3,4],[5,6,7,8],[9,10,11,12]]) print("void") void(2*3) void(void(void(void(void(2*3))))) void(print("Dit was void")) print("W_action") W_action([1,0],[2],A2) W_action([1,0],[1],A2) setdefault(E7) W_action([1,1,1,1,1,1,1],long_word) W_action([2,345,863,-724],[4,2,3,1,3,1,3,2,4,3,1,2,3,2,4,2,4,2,3,1,3,2],F4) W_action([-8,17,1000],[],T3) W_action([],[],T0) setdefault(G2A1T3) W_action([0,1,1,-8,17,1000],[2,3,2,3,1,2,1,3]) print("W_action") W_action([],T0) W_action([],T3) W_action([1,2,3,2],A1A2) setdefault(T4D4E8F4) W_action([2,3,4,3,2,1,2,3,5,6,7,8,9,10,11,12, 11,10,9,8,7,8,9,8,7,6,13,14,15,16]) W_action([],A1B2C2D3T6) print("W_orbit") W_orbit([1,0],G2) setdefault(A3) W_orbit([0,1,0]) W_orbit([1,0,0,0],G2A2) W_orbit([1,1,0,0],F4) setdefault(E8) W_orbit([0,0,0,0,0,0,0,1]) W_orbit([],T0) W_orbit([56,-1000,0],T3) setdefault(T2A2F4) W_orbit([1,1,1,0,0,0,90,-81]) print("W_orbit_size") W_orbit_size([1,0,0,0,0,0,0,0],E8) setdefault(F4) W_orbit_size([1,1,2,0]) W_orbit_size([1,0,0,0],G2A2) W_orbit_size([],T0) W_orbit_size([100,-92],T2) setdefault(F4G2T2E8) W_orbit_size([1,0,0,1,0,0,1,0,0,0,0,0,0,0,-89,1000]) print("W_order") W_order(T0) W_order(T3) W_order(E7) setdefault(D10) W_order W_order(G2A2T5E8E8E8E8E8E8) print("W_rt_action") W_rt_action([],[],T3) W_rt_action([1,0],[2],A2) setdefault(G2G2T3) W_rt_action([1,100,-89,0],[1,3]) print("W_rt_orbit") W_rt_orbit([1,0,0],A3) W_rt_orbit([],T0) setdefault(G2A1T3) W_rt_orbit([-4,100,-91]) print("W_word") W_word([-1,-2,-3,-4,-5],T5) W_word([-1,-4,-1,-1,4,-5],E6) setdefault(F4A1T2) W_word([-3,9,12,100,-91,4,6]) W_word(id(3),T3) W_word([[0,0,-1,1],[1,-1,-1,1],[1,-1,0,1],[1,0,-1,0]],D4) setdefault(G2A3T1) W_word([[1,-1,0,0,0,0],[3,-2,0,0,0,0],[0,0,0,0,-1,0],\ [0,0,-1,1,-1,0],[0,0,-1,0,0,0],[0,0,0,0,0,1]]) LiE/progs/testorb0000644000175000017500000000015406043127153013215 0ustar hakanhakantestorb(grp g)= { for r row id(Lie_rank(g)) do W_orbit(r,g); W_rt_orbit(r,g) od ; print("group "+g+" OK") } LiE/progs/testsuite0000644000175000017500000000407405076527122013576 0ustar hakanhakanprint("recursie tests") f(int i)=if i==0 then 0 else 1+f(i-1) fi if 50!=f(50) then print("error een") fi f(int i)=g(i) g(int i)=if i==0 then 0 else 1+f(i-1) fi if 30!=f(30) then print("error twee") fi f(int i)=if i==0 then 0 else if i==1 then 1 else f(i-1)+f(i-2) fi fi if f(10)!=55 then print("error drie") fi ag=30 f()=loc af=ag-1; if af==0 then 1 else 1+g fi g()=loc ag=af-1; if ag==0 then 1 else 1+f fi if f!=30 then print("error vier") fi f(int n)=if n==1 then 1 else 2*f(f(n/2)) fi if f(2^12)!=2^12 then print("error vijf") fi f(vec v)=if size(v)==0 then 0 else f(v-size(v))+v[size(v)] fi g(mat m)=if n_rows(m)==0 then 0 else g(m-n_rows(m))+f(m[n_rows(m)]) fi if g(id(10))!=10 then print("error zes") fi print("loop tests") if 10!=for i=1 to 10 do i od then print("error een") fi k=0 for i=1 to 2 do for j=0 to 2 do for l=-1 to 3 do k=k+1 od od od if k!=2*3*5 then print("error twee") fi k=0; l=0 for k=1 to 2 do for k=0 to 1 do l=l+1 od od if k!=0||l!=4 then print("error drie") fi k=0 for v row id(3) do for i in v do for j=1 to i do k=k+1 od od od if k!=3 then print("error vier") fi k=0 for i=1 to 2 do for i=0 to 1 do k=k+1 od; for i=2 to 3 do k=k+1 od od if k!=8 then print("error vijf") fi k=0 for i=1 to 0 do k=k+1 od if k!=0 then print("error zes") fi k=0 for i=for i=-1000 to -999 do k=k+1; 2000 od\ to for i=2000 to 2001 do k=k+1;i od\ do k=k+1 od if k!=6 then print("error zeven") fi k=0; l=0 for k=for l=1 to 2 do k=k+1;k od to for k=2 to 3 do l=l+1; k od do l=10*l od if k!=2||l!=200 then print("error acht") fi k=0; m=[[1,2,3],[4,5,6]] for m row m do for m in m do k=k+m od od if k!=21 then print("error negen") fi k=0 for v row m do for v row m do\ if v==m[2] then break else k=k+v[1]+v[2]+v[3] fi od od if k!=12 then print("error tien") fi k=0 for i=for i=1 to 3 do if i>1 then break(i) else 0 fi od to 2 do k=k+1 od if k!=1 then print("error elf") fi k=0 for i=1 to for i=1 to 3 do if i>1 then break(i) else 1 fi od do k=k+1 od if k!=2 then print("error twaalf") fi print("recursie in combinatie met loop tests") k=0 f(int n)=k=k+1; if n>0 then for n=1 to n do f(n-1) od else 1 fi LiE/static/0002775000175000017500000000000007072650442011756 5ustar hakanhakanLiE/static/Makefile0000644000175000017500000000055607072605612013417 0ustar hakanhakanc_sources=static1.c static2.c static4.c static5.c static6.c static7.c .SUFFIXES: %.o: %.c $(CC) -c $(CPPFLAGS) $(all-C-flags) $< .last_compiled: $(c_sources:.c=.o) touch .last_compiled all: .last_compiled # TAGS file with identifier definitions for emacs perusal. TAGS: $(c_sources) etags $(c_sources) # standard targets clean: rm -f *.o .last_compiled LiE/static/static1.c0000644000175000017500000005356307120144567013502 0ustar hakanhakan#include "lie.h" static void error_unequal(entry a,entry b) { error("Number of components unequal (%ld <-> %ld).\n",(long)a,(long)b); } static object vecmake(symblst arglst) { index i, n; symblst list; object result; list = arglst; n = 0; while (list) { eval_value( list); list = list->next; n++; } list = arglst; result = (object) mkvector(n); for (i = 0; i < n; i++) { result->v.compon[i] = Integer(list->data.val); list = list->next; } return (result); } static object matmake(symblst arglst) { object result; symblst list; index i, j, nr=0, nc=0, nc_last=0; for (list=arglst; list!=NULL; list=list->next, ++nr) { eval_value(list); nc = list->data.val->v.ncomp; if (nr>0 && nc!=nc_last) error("Matrix: Rows of unequal length.\n"); nc_last = nc; } list=arglst; result = (object) mkmatrix(nr, nc); for (i = 0; inext) for (j = 0; jm.elm[i][j] = list->data.val->v.compon[j]; return (result); } static object vec_make(funsym) symblst funsym; { index i, size; object result; symblst f, sizesym; object funargobj; strtype fun_name_old = fun_name; sizesym = funsym->next; eval_value(sizesym); size = Integer(sizesym->data.val); if (size<0) error("MAKE cannot make a vector of negative size \n"); result = (object) mkvector(size); addstaynode(result); f= newnode(funsym->a.label); fun_name = funsym->a.label->name; for (i = 0; iarglst); funargobj->i.intval = i + 1; evalbl_value_dup(f,funsym); result->v.compon[i] = Integer(f->data.val); } fun_name = fun_name_old; return (result); } static object mat_make(funsym) symblst funsym; { index i, j, rowsize, colsize; object result; symblst f, rowsizesym, colsizesym; object funarg1obj, funarg2obj; strtype fun_name_old = fun_name; rowsizesym = funsym->next; colsizesym = rowsizesym->next; funsym->next = NULL; /* Disconnect funsym from sizesym */ eval_value(rowsizesym); rowsize = Integer(rowsizesym->data.val); eval_value(colsizesym); colsize = Integer(colsizesym->data.val); if (rowsize<0) error("Negative rowsize.\n"); if (colsize<0) error("Negative colsize\n"); result = (object) mkmatrix(rowsize, colsize); f= newnode(funsym->a.label); addstaynode(result); fun_name = funsym->a.label->name; for (i = 0; iarglst); funarg2obj = force_integer(funsym->arglst->next); funarg1obj->i.intval = i + 1; funarg2obj->i.intval = j + 1; evalbl_value_dup(f,funsym); result->m.elm[i][j] = Integer(f->data.val); } } fun_name = fun_name_old; return (result); } static object mat_apply(symblst funsym) { index rowsize, colsize, i,j; object result; object funarg1obj, funarg2obj; symblst f, mat1sym, mat2sym; strtype fun_name_old = fun_name; mat1sym = funsym->next; mat2sym = mat1sym->next; eval_value(mat1sym); if (mat1sym->type!=MATRIX) error("System error mat_apply.\n"); rowsize = mat1sym->data.val->m.nrows; colsize = mat1sym->data.val->m.ncols; if (mat2sym) { eval_value(mat2sym); if (mat2sym->type!=MATRIX) error("System error mat_apply.\n"); if (mat2sym->data.val->m.nrows != rowsize || mat1sym->data.val->m.ncols != colsize) error("Dimensions left and right operands unequal.\n"); } result = (object) mkmatrix(rowsize, colsize); addstaynode(result); f= newnode(funsym->a.label); fun_name = funsym->a.label->name; for (i = 0; iarglst); funarg1obj->i.intval=mat1sym->data.val->m.elm[i][j]; if (mat2sym!=NULL) { funarg2obj = force_integer(funsym->arglst->next); funarg2obj->i.intval=mat2sym->data.val->m.elm[i][j]; } evalbl_value_dup(f,funsym); result->m.elm[i][j]= Integer(f->data.val); } fun_name = fun_name_old; return (result); } static object vec_apply(symblst funsym) { index i, n, size; object result, funarg1obj, funarg2obj; symblst f, vec1sym, vec2sym; strtype fun_name_old = fun_name; vec1sym = funsym->next; vec2sym = vec1sym->next; eval_value(vec1sym); if (vec1sym->type!=VECTOR) return (NULL); size = vec1sym->data.val->v.ncomp; if (vec2sym) { eval_value(vec2sym); if (vec2sym->type!=VECTOR) error("System error vec_apply.\n"); if (vec2sym->data.val->v.ncomp != size) error("index vector arguments unequal.\n"); } result = (object) mkvector(size); addstaynode(result); f= newnode(funsym->a.label); n = size; fun_name = funsym->a.label->name; for (i = 0; iarglst); funarg1obj->i.intval = vec1sym->data.val->v.compon[i]; if (vec2sym!=NULL) { funarg2obj = force_integer(funsym->arglst->next); funarg2obj->i.intval = vec2sym->data.val->v.compon[i]; } evalbl_value_dup(f,funsym); *(result->v.compon + i) = Integer(f->data.val); } fun_name = fun_name_old; return (result); } static object ifmap_int(arglst) symblst arglst; { symblst left = arglst->next; symblst right = left->next; boolean crit; eval_value(arglst); crit = Integer(arglst->data.val)!=0; clrshared(arglst->data.val); freemem(arglst->data.val); if (crit) { eval_value(left); return (left->data.val); } else { if (right) { eval_value(right); return (right->data.val); } return (object) NULL; } } static object ifmap_pol(arglst) symblst arglst; { symblst left = arglst->next; symblst right = left->next; poly *crit; eval_value(arglst); crit = (poly*) arglst->data.val; if (!issorted(crit)) crit = Reduce_pol(crit); if (crit->nrows > 1 || crit->coef[0]->size) { eval_value(left); return (left->data.val); } else { if (right) { eval_value(right); return (right->data.val); } return (object) NULL; } } static object ifmap_vec(arglst) symblst arglst; { symblst left = arglst->next, right = left->next; index i=0; vector *selector; index ncomp; eval_value(arglst); selector = (vector*) arglst->data.val; ncomp = selector->ncomp; while (icompon[i]) i++; if (i != ncomp) { /* vector unequal to zero vector */ eval_value(left); return (left->data.val); } else { if (right) { eval_value(right); return (right->data.val); } return (object) NULL; } } static object ifmap_mat(arglst) symblst arglst; { symblst left = arglst->next, right = left->next; index i=0,j=0; matrix *selector; entry nrows, ncols; eval_value(arglst); selector = (matrix*) arglst->data.val; nrows = selector->nrows; ncols = selector->ncols; j = ncols; while (ielm[i][j]) j++; i++; } if (i != nrows || j != ncols) { /* matrix unequal to zero matrix */ eval_value(left); return (left->data.val); } else { if (right) { eval_value(right); return (right->data.val); } return (object) NULL; } } static object vec_min_vec(vector* a) { index i; vector* result= mkvector(a->ncomp); for (i = 0; incomp; ++i) result->compon[i] = -a->compon[i]; return (object) result; } static object vec_not_vec(vector* a) { index i, n=a->ncomp; vector* result= mkvector(n); for (i = 0; icompon[i] = a->compon[n-1-i]; return (object) result; } static object mat_min_mat(a) object a; { object result; index i, j; result = (object) mkmatrix(a->m.nrows, a->m.ncols); for (i = 0; im.nrows; i++) { for (j = 0; jm.ncols; j++) *(*(result->m.elm + i) + j) = -*(*(a->m.elm + i) + j); } return (result); } static entry imod(entry x,entry n) { return x>=0 ? x%n : -x%n==0 ? 0 : n-(-x%n) ; } static object vec_mod_vec_int(a, b) object a, b; { object result; index i; entry g = b->i.intval; if (g<0) error("LiE can only take the modulus by a positive number.\n"); result = (object) mkvector(a->v.ncomp); for (i = 0; iv.ncomp; i++) result->v.compon[i] = imod(a->v.compon[i],g); return result; } static object mat_div_mat_int(a, b) object a, b; { index i,j; entry g = b->i.intval; object result; index n = a->m.ncols, m =a->m.nrows; if (!g) error("Division by zero\n"); result = (object) mkmatrix(a->m.nrows, a->m.ncols); for (i = 0; im.elm + i) + j) = *(*(a->m.elm + i) + j)/g; return (result); } static object mat_mod_mat_int(a, b) object a, b; { index i, j; entry g = b->i.intval; index m = a->m.nrows, n = a->m.ncols; object result; if (g<0) error("LiE can only take the modulus by a positive number.\n"); result = (object) mkmatrix(a->m.nrows, a->m.ncols); for (i = 0; im.elm + i) + j) = imod(*(*(a->m.elm + i)+j), g); return (result); } static object bin_pow_bin_bin(object a, object b) { if (b->b.size<0) error("Negative exponent; I cannot compute that power.\n"); return power(a,(bigint*)b,(object)one,(f2object)mult); } static object pol_pow_pol_bin(object a, object b) { if (b->b.size<0) error("Negative exponent; I cannot compute that power.\n"); return power(a,(bigint*)b,(object)poly_one(a->pl.ncols) ,(f2object)Mul_pol_pol); } static object vec_mul_int_vec(a, b) object a, b; { object result; index i; result = (object) mkvector(b->v.ncomp); for (i = 0; iv.ncomp; i++) result->v.compon[i] = a->i.intval * b->v.compon[i]; return (result); } static object vec_div_vec_int(a, b) object a, b; { object result; index i; entry g = b->i.intval; result = (object) mkvector(a->v.ncomp); if (!g) error("Division by 0\n"); for (i = 0; iv.ncomp; i++) result->v.compon[i] = a->v.compon[i]/g; return (result); } static object vec_mul_mat_vec(a, b) object a, b; { index i, k, n, m; object result; if (a->m.ncols != b->v.ncomp) error("Number columns arg1 unequal number of components arg2 .\n"); n = a->m.nrows; m = a->m.ncols; result = (object) mkvector(n); for (i = 0; iv.compon[i] = 0; for (k = 0; kv.compon[i] += b->v.compon[k] * *(*(a->m.elm + i) + k); } return result; } static object vec_mul_vec_mat(v, m) object v, m; { index i, k, nrows=m->m.nrows, ncols=m->m.ncols; object result; if (v->v.ncomp != nrows) error("Number rows arg2 unequal number of components arg1 .\n"); result = (object) mkvector(ncols); for (i = 0; iv.compon[i] = 0; for (k = 0; kv.compon[i] += v->v.compon[k] * *(*(m->m.elm + k) + i); } return result; } static object vec_append_vec_vec(v,w) object v,w; { object result; index i,nv=v->v.ncomp, nw=w->v.ncomp; result = (object) mkvector(nv+nw); for (i=0;iv.compon[i]=v->v.compon[i]; for (i=0;iv.compon[nv+i]=w->v.compon[i]; return result; } static object mat_mul_mat_mat(a, b) object a, b; { if (a->m.ncols != b->m.nrows) error("Number columns arg1 unequal number of rows arg2 .\n"); return (object) Matmult((matrix *) a, (matrix *) b); } static object pol_mul_pol_mat(a, b) poly *a; matrix *b; { poly *m; int i; if (a->ncols != b->nrows) error("Number variables arg1 unequal number of rows arg2 .\n"); m = mkpoly(a->nrows,b->ncols); mulmatmatelm(a->elm,b->elm,m->elm,a->nrows,a->ncols,b->ncols); for (i=0;inrows;i++) { m->coef[i] = a->coef[i]; setshared(m->coef[i]); } return (object) m; } matrix* mat_null (index r,index c) { index i,j; matrix* m=mkmatrix(r,c); entry** me=m->elm; for (i=0;ielm; for (i=0;im.ncols != a->m.nrows) error("Number of columns unequal number of rows.\n"); if (b->b.size<0) error("Matrix raised to negative power.\n"); return power(a,(bigint*)b,(object)mat_id(a->m.nrows),(fobject)Matmult); } static object mat_append_mat_mat(a,b) object a,b; { object result; index i,n1=a->m.nrows,n2=b->m.nrows,m; if (a->m.ncols != b->m.ncols) error("Unequal number of columns. (%ld <-> %ld) \n", (long)a->m.ncols, (long)b->m.ncols); m=a->m.ncols; result = (object) mkmatrix(n1+n2,m); for (i=0;im.elm[i],result->m.elm[i],m); for (i=0;im.elm[i],result->m.elm[n1+i],m); return result; } static object mat_transpose_mat(a) object a; { return (object) Transpose((matrix *) a); } static object int_mul_vec_vec(a, b) object a, b; { object result; index sum, i; if (a->v.ncomp != b->v.ncomp) error_unequal(a->v.ncomp, b->v.ncomp); sum = 0; for (i = 0; iv.ncomp; i++) sum += a->v.compon[i] * b->v.compon[i]; result = (object) mkintcel(sum); return (result); } object vec_add_vec_vec(object v, object w) { index i; vector* a=&v->v,* b=&w->v; vector* result; if (a->ncomp != b->ncomp) error_unequal(a->ncomp,b->ncomp); result = isshared(a) ? copyvector(a) : a; for (i = 0; incomp; ++i) result->compon[i] += b->compon[i]; return (object) result; } object mat_add_mat_vec(a, v) object a, v; { object result; index m = a->m.nrows, n = a->m.ncols; index i,j; if (a->m.ncols != v->v.ncomp) error("Number of vector components unequal number of columns .\n"); if (isshared(a) || a->m.rowsize == m) { result = (object) mkmatrix(2 * m + 1, n); for (i = 0; im.elm + i)+j) = *(*(a->m.elm + i)+j); } else result = a; for (j = 0; jm.elm + m)+j) = v->v.compon[j]; result->m.nrows = m + 1; return (result); } static object mat_sub_mat_int(a, obj_k) object a, obj_k; { object result; index m = a->m.nrows, n = a->m.ncols; index k = obj_k->i.intval-1; index i,j; if (k >= m || k<0) error("Index %ld out of range.\n",(long)(k+1)); if (isshared(a) || a->m.rowsize == m) { result = (object) mkmatrix(m - 1, n); for (i = 0; im.elm + i)+j) = *(*(a->m.elm + i)+j); for (i = k+1; i< m;i++) for (j = 0; jm.elm + i-1)+j) = *(*(a->m.elm + i)+j); } else { result = a; for (i = k+1; i< m;i++) *(result->m.elm+i-1) = *(result->m.elm+i); result->m.nrows = m - 1; } return result; } static object vec_dif_vec_vec(a, b) object a, b; { object result; index i; if (a->v.ncomp != b->v.ncomp) error_unequal(a->v.ncomp, b->v.ncomp); result = (object) mkvector(a->v.ncomp); for (i = 0; iv.ncomp; i++) result->v.compon[i] = a->v.compon[i] - b->v.compon[i]; return (result); } object mat_add_mat_mat(a, b) object a, b; { object result; index i,j; index n = a->m.ncols,m = a->m.nrows; if (a->m.nrows != b->m.nrows) error("Number of rows of matrix arguments unequal.\n"); if (a->m.ncols != b->m.ncols) error("Number of columns of matrix arguments unequal.\n"); if (isshared(a)) result = (object) copymatrix((matrix*) a); else result = a; for (i = 0; im.elm + i) + j) += *(*(b->m.elm + i) + j); return result; } static object mat_sub_mat_mat(a, b) object a, b; { object result; index i,j; index n=a->m.ncols, m=a->m.nrows; if (a->m.nrows != b->m.nrows) error("Number of rows of matrix arguments unequal.\n"); if (a->m.ncols != b->m.ncols) error("Number of columns of matrix arguments unequal.\n"); result = (object) mkmatrix(a->m.nrows, a->m.ncols); for (i = 0; im.elm + i) + j) = *(*(a->m.elm + i) + j) - *(*(b->m.elm + i) + j); return (result); } static object mat_mul_int_mat(a, b) object a, b; { object result; index i,j; entry g = a->i.intval; index n = b->m.ncols, m = b->m.nrows; result = (object) mkmatrix(b->m.nrows, b->m.ncols); for (i = 0; im.elm + i) + j) = *(*(b->m.elm + i) + j) * g; return (result); } static object int_siz_vec(a) object a; { object result; result = (object) mkintcel(a->v.ncomp); return (result); } static object int_rowsiz_mat(a) object a; { object result; result = (object) mkintcel(a->m.nrows); return (result); } static object int_colsiz_mat(a) object a; { object result; result = (object) mkintcel(a->m.ncols); return (result); } static object int_n_vars_pol(p) object p; { return (object) mkintcel(p->pl.ncols); } static object mat_null_int_int(object m_obj,object n_obj) { index r = Integer(m_obj), c = Integer(n_obj); if (r<0) error("row size<0\n"); if (c<0) error("column size<0\n"); return (object) mat_null(r,c); } static object mat_one_int_int(m_obj,n_obj) object m_obj,n_obj; { index i,j,r=Integer(m_obj), c=Integer(n_obj); matrix* m; if (r<0) error("row size<0\n"); if (c<0) error("column size<0\n"); m=mkmatrix(r,c); for (i=0;ielm[i][j]=1; return (object) m; } static object pol_null_int(r) intcel *r; { index d = r->intval; if (d<0) error("n_vars of polynomial negative (=%ld)",(long)d); return (object) poly_null(d); } static object pol_one_int(r) intcel *r; { index d = r->intval; if (d<0) error("n_vars of polynomial negative (=%ld)",(long)d); return (object) poly_one(d); } static object mat_unit_int(intcel* nn) { index n=nn->intval; if (n<0) error("Cannot create identity matrix of negative size %ld.\n",(long)n); return (object) mat_id(n); } static object vec_unit_int_int(intcel* nn, intcel* ii) { index n=nn->intval, i=ii->intval,j; vector* result; entry* v; if (i<0 || i>n) error("Cannot create unit vector %ld of size %ld.\n",(long)i,(long)n); result=mkvector(n); v=result->compon; for (j=0; jintval,j; vector* result; entry* v; if (n<0) error("Cannot create vector of negative size %ld.\n",(long)n); result=mkvector(n); v=result->compon; for (j=0; jintval,j; vector* result; entry* v; if (n<0) error("Cannot create vector of negative size %ld.\n",(long)n); result=mkvector(n); v=result->compon; for (j=0; jnext; eval_value(a); if (Integer(a->data.val)) eval_value(b); else return (object) bool_false; if (Integer(b->data.val)) return (object) bool_true; return (object) bool_false; } static object int_or_int_int(a) symblst a; { symblst b=a->next; eval_value(a); if (Integer(a->data.val)) return (object) bool_true; eval_value(b); if (Integer(b->data.val)) return (object) bool_true; return (object) bool_false; } static object int_not_int(a) object a; { object result; result=(object) mkintcel(!a->i.intval); return (result); } static object int_eq_mat_mat(a,b) object a,b; { index i=0, m=a->m.nrows, n=a->m.ncols; if (a->m.nrows != b->m.nrows) return (object) bool_false; if (a->m.ncols != b->m.ncols) return (object) bool_false; while (i < m && eqrow(*(a->m.elm+i),*(b->m.elm+i),n)) i++; if (i == m) return (object) bool_true; return (object) bool_false; } static object int_eq_pol_pol(a, b) object a, b; { index i=0, nrows; if (!issorted(a)) a=(object) Reduce_pol((poly*) a); if (!issorted(b)) b=(object) Reduce_pol((poly*) b); if (int_eq_mat_mat(a, b) == (object) bool_false) return (object) bool_false; nrows=a->m.nrows; while (i < nrows && !cmp(a->pl.coef[i],b->pl.coef[i])) i++; if (i == nrows) return (object) bool_true; return (object) bool_false; } static object int_ne_mat_mat(a,b) object a,b; { index i=0, m=a->m.nrows, n=a->m.ncols; if (a->m.nrows != b->m.nrows) return (object) bool_true; if (a->m.ncols != b->m.ncols) return (object) bool_true; while (i < m && eqrow(*(a->m.elm+i),*(b->m.elm+i),n)) i++; if (i != m) return (object) bool_true; return (object) bool_false; } static object int_ne_pol_pol(a, b) object a, b; { index i=0, nrows; if (!issorted(a)) a=(object) Reduce_pol((poly*) a); if (!issorted(b)) b=(object) Reduce_pol((poly*) b); if (int_ne_mat_mat(a, b) == (object) bool_true) return (object) bool_true; nrows=a->m.nrows; while (i < nrows && !cmp(a->pl.coef[i],b->pl.coef[i])) i++; if (i == nrows) return (object) bool_false; return (object) bool_true; } static object int_eq_vec_vec(a, b) object a, b; { index i, n; if (a->v.ncomp != b->v.ncomp) return (object) bool_false; n=a->v.ncomp; i=0; while (i < n && *(a->v.compon + i) == *(b->v.compon + i)) i++; if (i == n) return (object) bool_true; return (object) bool_false; } static object int_ne_vec_vec(a, b) object a, b; { index i, n; if (a->v.ncomp != b->v.ncomp) return (object) bool_true; n=a->v.ncomp; i=0; while (i < n && *(a->v.compon + i) == *(b->v.compon + i)) i++; if (i != n) return (object) bool_true; return (object) bool_false; } object vec_addelm_vec_int(a, b) object a, b; { index i, n; entry k; object result; n=a->v.ncomp; k=Integer(b); if (isshared(a) || a->v.size == n) { result=(object) mkvector(2 * n + 1); for (i=0; i < n; i++) result->v.compon[i]=a->v.compon[i]; } else result=a; result->v.compon[n]=k; result->v.ncomp=n + 1; return (result); } static object vec_startaddelm_int_vec(a, b) object a, b; { index i, n, k; object result; n=b->v.ncomp; k=a->i.intval; result=(object) mkvector(n + 1); result->v.compon[0]=k; for (i=0; i < n; i++) result->v.compon[i + 1]=b->v.compon[i]; return (result); } static object vec_subelm_vec_int(a, b) object a, b; { index i, n, k; object result; n=a->v.ncomp; k=b->i.intval - 1; if (n <= 0) error("Cannot delete from an empty vector.\n"); if (k < 0 || k >= n) error("Index for deletion of vector component out of range.\n"); result=(object) mkvector(n - 1); for (i=0; i < k; i++) result->v.compon[i]=a->v.compon[i]; for (i=k + 1; i < n; i++) result->v.compon[i - 1]=a->v.compon[i]; return (result); } static object int_select_vec_int(t, n) vector *t; intcel *n; { object result; index index1; index1=n->intval; if (index1 < 1 || index1 > t->ncomp) error("Index (%ld) into vector out of range \n", (long)index1); result=(object) mkintcel(t->compon[index1 - 1]); return (result); } static object vec_select_mat_int(m, indexobj) object m, indexobj; { index index1; object result; index n, i; index1=indexobj->i.intval; if (index1 < 1 || index1 > m->m.nrows) error("Row index (%ld) into matrix out of range \n", (long)index1); result=(object) mkvector(m->m.ncols); n=m->m.ncols; index1--; for (i=0; i < n; i++) result->v.compon[i]=m->m.elm[index1][i]; return (result); } static object pol_select_pol_int(m, indexobj) poly *m; intcel *indexobj; { index index1; poly *result; index n, i; entry *elm, *melm; index1=indexobj->intval - 1; if (index1 < 0 || index1 >= m->nrows) error("Index (%ld) into polynomial out of range \n", (long)(index1+1)); if (!issorted(m)) m= Reduce_pol(m); result=mkpoly(1,m->ncols); elm=result->elm[0]; n=m->ncols; result->coef[0]=m->coef[index1]; setshared(result->coef[0]); melm=m->elm[index1]; for (i=0; i < n; i++) elm[i]=melm[i]; return (object) result; } static object vec_select_pol_int(m, indexobj) poly *m; intcel *indexobj; { index index1; vector *result; index n; entry *elm, *melm; index1=indexobj->intval - 1; if (index1 < 0 || index1 >= m->nrows) error("Index (%ld) into polynomial out of range \n", (long)(index1+1)); if (!issorted(m)) m= Reduce_pol(m); result=mkvector(m->ncols); elm=result->compon; n=m->ncols; melm=m->elm[index1]; copyrow(melm,elm,n); return (object) result; } static object bin_select_pol_vec(p,v) poly *p; vector *v; { index nvars=p->ncols; entry *compon=v->compon; index index1; if (v->ncomp != nvars) error("%ld indices were required - %ld were present.\n" , (long)nvars, (long)v->ncomp); index1=searchterm(p, compon); if (index1 < 0) return (object) null; return (object) p->coef[index1]; } static object Int_search_mat_vec(m,v,low,up) matrix* m; vector* v; index low,up; { /*************************************************************** * Returns the first index of vector v in matrix m * ***************************************************************/ index nrows=(m->nrowsnrows:up); index ncols=m->ncols; index i=(low<0?0:low); entry **elm=m->elm; entry *compon=v->compon; /*************************************************************** * Lineair search * ***************************************************************/ if (v->ncomp != ncols) error("%ld entries were required - %ld entries present.\n" , (long)ncols, (long)v->ncomp); while (i < nrows && !eqrow(elm[i],compon,ncols)) i++; if (i < nrows) return (object) mkintcel(i+1); return (object) bool_false; } static object int_search_mat_vec(m,v) matrix *m; vector *v; { return Int_search_mat_vec(m,v,0,m->nrows); } static object int_search_mat_vec_int_int(m,v,low,up) matrix *m; vector *v; intcel *up, *low; { return Int_search_mat_vec(m,v,low->intval-1, up->intval); } static object int_select_mat_int_int(m, n1, n2) matrix *m; intcel *n1, *n2; { index index1; index index2; index1=n1->intval - 1; index2=n2->intval - 1; if (index1 < 0 || index1 >= m->nrows) error("Row index (%ld) into matrix out of range \n",(long)(index1+1)); if (index2 < 0 || index2 >= m->ncols) error("Column index (%ld) into matrix out of range \n",(long)(index2+1)); return (object) mkintcel(m->elm[index1][index2]); } static object int_used() { return ((object) mkintcel(chunks)); } static object arg_break_arg(a) object a; { stop_loop=a; return a; } static object arg_return_arg(a) object a; { stop_fun=a; return nothing; } static object vid_break() { stop_loop=nothing; return nothing; } static object vid_return() { stop_fun=nothing; return nothing; } static object apply(funsym) symblst funsym; { entry size; index i; symblst sizesym=funsym->next; symblst unitsym=funsym->arglst; symbrec f[1]; strtype fun_name_old=fun_name; object stop_later=stop_loop; stop_loop=NULL; eval_value( sizesym); size=Integer(sizesym->data.val); if (size < 0) error("IAPPLY cannot repeat a negative number of times.\n"); eval_value( unitsym); fun_name=funsym->a.label->name; for (i=0; i < size; i++) { evalbl_value_dup(f,funsym); assignsym(unitsym,f); if (stop_loop!=NULL) break; } fun_name=fun_name_old; stop_loop=stop_later; return unitsym->data.val; } static object vec_apply_int_int(funsym) symblst funsym; { index size, n; index i; object result, unitobj; object stop_later=stop_loop; symblst sizesym=funsym->next; symblst unitsym=funsym->arglst; symbrec f[1]; strtype fun_name_old=fun_name; stop_loop=false; eval_value( sizesym); size=Integer(sizesym->data.val); if (size < 0) error("VAPPLY cannot make a vector of negative size \n"); eval_value( unitsym); if (type_of(unitsym) == BIGINT) { unitsym->data.val=(object)(*bin2int)(&unitsym->data.val->b); unitsym->type=type_of(unitsym->data.val); } if (type_of(unitsym) != VECTOR && !is_int(type_of(unitsym))) error("vapply: Illegal unit.\n"); unitobj=unitsym->data.val; n=(is_int(type_of(unitsym)) ? 1 : unitobj->v.ncomp); result=(object) mkvector(size + n); addstaynode(result); result->v.ncomp=n; if (is_int(type_of(unitsym))) result->v.compon[0]=Integer(unitobj); else { for (i=0; i < n; i++) result->v.compon[i]=unitobj->v.compon[i]; unitsym->data.val=result; } fun_name=funsym->a.label->name; for (i=0; i < size; i++) { evalbl_value_dup(f,funsym); result->v.compon[result->v.ncomp++]=Integer(f->data.val); if (is_int(type_of(unitsym))) assignsym(unitsym,f); if (stop_loop!=NULL) break; } fun_name=fun_name_old; stop_loop=stop_later; return result; } static object vec_join_mat(object a) { object result; index i,j, n=a->m.nrows, m=a->m.ncols; result=(object) mkvector(a->m.nrows * a->m.ncols); for (i=0; i < n; i++) for (j=0; j < m; j++) result->v.compon[m * i + j]=a->m.elm[i][j]; return result; } static object vec_diag_mat(a) object a; { object result; index i; index n=a->m.nrows, m=a->m.ncols; index size; if (n > m) size=m; else size=n; result=(object) mkvector(size); for (i=0; i < size; i++) { result->v.compon[i]=*(*(a->m.elm + i) + i); } return (result); } static poly* pol_monom_vec(v) vector *v; { poly *result; int i; result=mkpoly(1,v->ncomp); result->coef[0]=one; for (i=0; incomp; i++) result->elm[0][i]=v->compon[i]; return result; } static object pol_polynom_bin_mat(d,p) object p; bigint* d; { poly *result; index i; index nr=p->pl.rowsize,nc=p->pl.ncols; if (!isshared(p)) /* space for coef's already reserved in p, so use it: */ { p->pl.type=POLY; p->pl.coef=(bigint**) ((char*)p + sizeof(poly) + nr*sizeof(entry*) + nr*(nc*sizeof(entry))); if (nr == 0) { p->pl.coef[0]=null; p->pl.nrows=1; } else for (i=0; ipl.coef[i]=d; setshared(d); } return p; } result=mkpoly(p->m.nrows,p->m.ncols); for (i=0; im.nrows; i++) { copyrow(p->m.elm[i],result->elm[i],nc); result->coef[i]=d; setshared(d); } return (object) result; } static poly* pol_polynom_mat(p) matrix* p; { return &pol_polynom_bin_mat(one,(object)p)->pl; } static poly* pol_polynom_bin(k) bigint *k; { poly *result=mkpoly(1,0); result->coef[0]=k; setshared(k); return result; } static poly* pol_polynom_int(intcel *k) { bigint *b; entry d=k->intval; poly *result=mkpoly(1,0); b= d==0? null : d==1 ? one : entry2bigint(d); result->coef[0]=b; setshared(b); return result; } static matrix* mat_polynom_pol(p) poly *p; { matrix *m; entry i, nrows=p->nrows; if (!issorted(p)) p=Reduce_pol(p); if (nrows==1 && p->coef[0]->size==0) { index ncols=p->ncols; freepol(p); return(mkmatrix(0,ncols)); } m=(matrix*)p; if (!isshared(m)) { m->type=MATRIX; for (i=0;icoef[i]); freemem(p->coef[i]); } p->coef=(bigint**) NULL; } else m=copymatrix(m); return m; } static object pol_polynom_bin_vec(d,v) vector* v; bigint* d; { object result=(object) mkpoly(1,v->ncomp); entry i, ncomp=v->ncomp; result->pl.coef[0]=d; setshared(d); for (i=0; ipl.elm[0][i]=v->compon[i]; return result; } static object pol_polynom_vec(v) vector *v; { return pol_polynom_bin_vec(one,v); } static object pol_polynom_bin_int(d,k) intcel* k; bigint* d; { object result=(object) mkpoly(1,1); result->pl.coef[0]=d; setshared(d); result->pl.elm[0][0]=k->intval; return result; } static object pol_polynom_one_int(k) intcel *k; { return pol_polynom_bin_int(one,k); } static object bin_coef_pol_int(p,k) poly *p;intcel *k; { index i=k->intval - 1; if (i < 0 || i >= p->nrows) error("Index (%ld) into polynomial out of range.\n",(long)(i+1)); return (object) p->coef[i]; } static object pol_min_pol(a) poly *a; { poly *result; index n=a->nrows; int i; if (isshared(a)) result=copypoly(a); else result=a; for (i=0;icoef[i]; if (isshared(c)){ c=copybigint(c, NULL); setshared(c); } c->size=-c->size; result->coef[i]=c; } return (object) result; } static object pol_add_pol_pol (a,b) object a,b; { return (object) Add_pol_pol((poly*) a, (poly*) b, false); } static object pol_sub_pol_pol (a,b) object a,b; { return (object) Add_pol_pol((poly*) a, (poly*) b, true); } static object pol_mul_bin_pol(a,b) object a,b; { return (object) Mul_bin_pol((bigint*) a, (poly*) b); } static object pol_mul_pol_int(a,b) object a,b; { return (object) Mul_pol_int((poly*) a, (intcel*) b); } static object pol_div_pol_bin(a,b) object a,b; { return (object) Div_pol_bin(&a->pl,&b->b); } static object pol_div_pol_vec(a,b) object a,b; { return (object) Div_pol_vec((poly*) a, (vector*) b); } static object pol_mod_pol_bin(a,b) object a,b; { return (object) Mod_pol_bin(&a->pl,&b->b); } static object pol_mod_pol_vec(a,b) object a,b; { return (object) Mod_pol_vec((poly*) a, (vector*) b); } static object pol_mul_pol_pol(a,b) object a,b; { return (object) Mul_pol_pol((poly*) a, (poly*) b); } static object int_deg_pol(p) object p; { return (object) mkintcel(Degree_pol((poly*) p)); } static object int_len_pol(p) object p; { entry l=p->pl.nrows; if (l == 1 && p->pl.coef[0]->size == 0) l--; return (object) mkintcel(l); } static object int_len_tek(t) tekst *t; { entry l=t->len; return (object) mkintcel(l); } static object pol_atensor_pol_pol(p1,p2) object p1, p2; { setshared(p1); setshared(p2); return (object) Disjunct_mul_pol_pol((poly*) p1, (poly*) p2);; } /* * Write here the interfaces above defined operations. */ #ifndef NOSAVEMAT static void rank_of_group_okay(group* g) { if (!simpgroup((object)g)) error("No subgroup data available for composite groups.\n"); if (Lierank((object)g)>RANKMAXSUB) error("No subgroup data available for groups of rank>%ld.\n" ,(long)RANKMAXSUB); if (Lierank((object)g)<2) error("Type A1 groups have no maximal subgroups.\n"); } static object tex_maxsub_grp(g) group *g; { rank_of_group_okay(g); return Objectread(g,"MAXSUB"); } static group* create_group(string s) { int i=0,count=0; object result; string t; for (t=s; *t; t++) if (isalpha(*t) && *t!='T') count++; /* counting */ result=(object) mkgroup(count); while (*s) { if (isalpha(*s)) /* this skips numbers after letter */ if (*s!='T') { char lietype= *s++; Liecomp(result,i++)=mksimpgrp(lietype,(index)atoi(s)); } else result->g.toraldim=(index)atoi(++s); s++; } if (i!=count) error("System error creating group %ld %ld\n",(long)i,(long)count); return (group*) result; } static object grp_maxsub_grp_int(nobj,g) group *g;intcel *nobj; { char *s; int i=0, start=0; int seq =0; object result= (object) NULL; entry n=nobj->intval; rank_of_group_okay(g); if (n<=0) error("Index < 0"); s=Objectread(g,"MAXSUB")->t.string; while (s[i]) { if (s[i]==',') { s[i]='\0'; seq++; if (seq == n) { result=(object) create_group(s+start); } start=i + 1; } i++; } /* The last one */ seq++; if (s[0] && (seq == n)) { result=(object) create_group(s+start); } if (!result) return (object) g; return result; } static object mat_resmat_grp_grp(g1,g2) group *g1,*g2; { string t; char *buf; object result; rank_of_group_okay(g2); buf=grp2str(g1); t=malloc(strlen(buf)+4); strcpy(t,buf); t=strcat(t,".1"); freem(buf); result= Objectread(g2,t); free(t); if (result==NULL) { Printf("Group "); printgrp((object)g2); Printf(" has no maximal subgroup of type "); printgrp((object)g1); error(".\n"); } return result; } static object mat_resmat_grp_int_grp(g1,d,g2) group *g1,*g2; intcel *d; { string t; object result; int n=d->intval; char* buf=grp2str(g1); t=malloc(strlen(buf)+4); sprintf(t,"%s.%d",buf,n); freem(buf); result= Objectread(g2,t); free(t); if (result==NULL) { Printf("Group "); printgrp((object)g2); Printf(" has less than %d maximal subgroups of type ",n); printgrp((object)g1); error(".\n"); } return result; } #endif Symbrec static2[]={ M3(".iapply", apply, INTEGER, INTFUN, INTEGER, INTEGER) M3(".vapply", apply, VECTOR, VECFUN, INTEGER, VECTOR) M3(".mapply", apply, MATRIX, MATFUN, INTEGER, MATRIX) M3(".vapply", vec_apply_int_int, VECTOR, INTFUN, INTEGER, INTEGER) M3(".vapply", vec_apply_int_int, VECTOR, INTFUN, INTEGER, VECTOR) C0("used", int_used, INTEGER) C1("!", int_not_int, INTEGER, INTEGER) M2("&&", int_and_int_int, INTEGER, INTEGER, INTEGER) M2("||", int_or_int_int, INTEGER, INTEGER, INTEGER) C2("==", int_eq_vec_vec, INTEGER, VECTOR, VECTOR) C2("!=", int_ne_vec_vec, INTEGER, VECTOR, VECTOR) C2("==", int_eq_mat_mat, INTEGER, MATRIX, MATRIX) C2("==", int_eq_pol_pol, INTEGER, POLY, POLY) C2("!=", int_ne_mat_mat, INTEGER, MATRIX, MATRIX) C2("!=", int_ne_pol_pol, INTEGER, POLY, POLY) C2("_select", int_select_vec_int, INTEGER, VECTOR, INTEGER) C3("_select", int_select_mat_int_int, INTEGER, MATRIX, INTEGER, INTEGER) C2("_select", pol_select_pol_int, POLY, POLY, INTEGER) C2("_select", vec_select_mat_int, VECTOR, MATRIX, INTEGER) C2("|", bin_select_pol_vec, BIGINT, POLY, VECTOR) C2("|", int_search_mat_vec, INTEGER, MATRIX, VECTOR) C4("row_index", int_search_mat_vec_int_int, INTEGER, MATRIX, VECTOR,INTEGER, INTEGER) C2("expon", vec_select_pol_int, VECTOR, POLY, INTEGER) C2("+", vec_addelm_vec_int, VECTOR, VECTOR, INTEGER) C2("+", vec_startaddelm_int_vec, VECTOR, INTEGER, VECTOR) C2("-", vec_subelm_vec_int, VECTOR, VECTOR, INTEGER) C1("_break", arg_break_arg, ARGTYPE, ARGTYPE) C0("_break", vid_break, ARGTYPE) C1("_return", arg_return_arg, ARGTYPE, ARGTYPE) C0("_return", vid_return, ARGTYPE) C1("vec_mat", vec_join_mat, VECTOR, MATRIX) C1("diag", vec_diag_mat, VECTOR, MATRIX) C2("coef", bin_coef_pol_int, BIGINT, POLY,INTEGER) C1("polynom", (fobject)pol_polynom_mat, POLY, MATRIX) C1("X", pol_polynom_vec, POLY, VECTOR) C1("X", (fobject)pol_polynom_mat, POLY, MATRIX) C1("X", pol_polynom_one_int, POLY, INTEGER) C2("X", pol_polynom_bin_vec, POLY, BIGINT, VECTOR) C2("X", pol_polynom_bin_mat, POLY, BIGINT, MATRIX) C2("X", pol_polynom_bin_int, POLY, BIGINT, INTEGER) C1("support", (fobject)mat_polynom_pol, MATRIX, POLY) C1("polynom", (fobject)pol_polynom_bin, POLY, BIGINT) C2("+", pol_add_pol_pol, POLY, POLY, POLY) C2("-", pol_sub_pol_pol, POLY, POLY, POLY) C1("-", pol_min_pol,POLY,POLY) C2("*", pol_mul_bin_pol, POLY, BIGINT, POLY) C2("*", pol_mul_pol_int, POLY, POLY, INTEGER) C2("*", pol_mul_pol_pol, POLY, POLY, POLY) C2("/", pol_div_pol_bin, POLY, POLY, BIGINT) C2("/", pol_div_pol_vec, POLY, POLY, VECTOR) C2("%", pol_mod_pol_bin, POLY, POLY, BIGINT) C2("%", pol_mod_pol_vec, POLY, POLY, VECTOR) C1("degree", int_deg_pol, INTEGER, POLY) C1("length", int_len_pol, INTEGER, POLY) C1("length", int_len_tek, INTEGER, TEKST) C2("^", pol_atensor_pol_pol, POLY, POLY, POLY) #ifndef NOSAVEMAT C1("max_sub", tex_maxsub_grp, TEKST, GRPDFT) C2("max_sub", grp_maxsub_grp_int, GROUP, INTEGER, GRPDFT) C2("res_mat", mat_resmat_grp_grp, MATRIX, GROUP, GRPDFT) C3("res_mat", mat_resmat_grp_int_grp, MATRIX, GROUP, INTEGER, GRPDFT) #endif }; int nstatic2=array_size(static2); poly* (*mat2pol) (matrix*)=pol_polynom_mat; matrix* (*pol2mat) (poly*) =mat_polynom_pol; poly* (*vec2pol) (vector*)=pol_monom_vec; poly* (*bin2pol) (bigint*)=pol_polynom_bin; poly* (*int2pol) (intcel*)=pol_polynom_int; LiE/static/static4.c0000644000175000017500000006731507215175614013507 0ustar hakanhakan/* static4 is engaged with type VOID */ #include "lie.h" #ifdef development extern int MEMCONTROL; #endif #ifdef __STDC__ typedef object symb_fun(symblst); static symb_fun vid_for, vid_downfor, vid_forvec, vid_format , arg_while_int_arg, vid_eval, arg_sequence, vid_assign, vid_assign_loc , vid_update_vec_int_int, vid_addassign_vec_int_int , vid_update_mat_int_int_int, vid_addassign_mat_int_int_int , vid_update_mat_vec_int, vid_vecupdate_pol_bin_vec , vid_update_pol_pol_int, vid_addupdate_vec_int , vid_addupdate_mat_vec, vid_addupdate_mat_mat , vid_addupdate_vec_vec, vid_addupdate_pol_pol , vid_addupdate_tex_tex, vid_addupdate_tex_bin ; static object vid_on_int_tex(intcel* n, tekst* t) , vid_off_int_tex(intcel* n, tekst* t) , vid_save(void), vid_restore(void), vid_on(void) , vid_for_a(symblst endsym,boolean increment) , vid_void_arg(object x), vid_void(void) , arg_nref_arg(object s) , mat_copy_mat_int_int_int_a (matrix*,object,object,object,boolean) , mat_copy_mat_int_int_int (matrix*,object,object,object) , mat_addassign_mat_int_int_int (matrix*,object,object,object) , vec_copy_vec_int_int_a (vector*,object,object,boolean) , vec_copy_vec_int_int(vector*,object,object) , vec_addassign_vec_int_int(vector*,object,object) , pol_copy_pol_bin_vec (poly*,object,vector*) , mat_copy_mat_vec_int(matrix*,vector*,object) , pol_copy_pol_pol_int(poly*,object,object) , pol_addc_pol_pol(object,object) , vid_error_tex(object) , int_eq_tex_tex(tekst*,tekst*) , tex_append_tex_tex(object,object) , tex_add_tex_bin(tekst*,bigint*) , tex_fmt_bin_int(bigint*,intcel*) , tex_add_tex_grp(tekst*,group*) , tex_add_grp_tex(group*,tekst*) , tex_add_bin_tex(bigint*,tekst*) , tex_mul_tex_int(tekst*,intcel*) , tex_mul_int_tex(intcel*,tekst*) , vid_addr(object) , mat_getmat_tex(tekst*) , tex_getstring_tex(tekst*) , vid_savemat_mat_tex(object,tekst*) , vid_savestring_tex_tex(object,tekst*); #endif boolean Boolean(object t) { return (is_int(type_of(t))?Integer(t)!=0: (eq_types(type_of(t),VECTOR)?!Vec_null(t): (eq_types(type_of(t),MATRIX)?!Mat_null(t): (eq_types(type_of(t),POLY)?!Pol_null(t):false) ) ) ); } static object vid_on_int_tex(n,t) intcel *n; tekst *t; { if (set_on(n->intval,match(t->string,false))) error("Option %s not found.\n",t->string); return (object) NULL; } static object vid_off_int_tex(n,t) intcel *n; tekst *t; { if (set_off(n->intval,match(t->string,false))) error("Option %s not found.\n",t->string); return (object) NULL; } static object vid_save() { save_state(); return (object) NULL; } static object vid_restore() { restore_state(); return (object) NULL; } static object vid_on() { print_state(); return (object) NULL; } static object vid_for_a(endsym,increment) symblst endsym; boolean increment; { object i_dex; symblst result; symblst blocksym = endsym->next; symblst topstack = topsym->next; entry endloop; object stop_later=stop_loop; stop_loop=NULL; eval_value(endsym); endloop = Integer(endsym->data.val); result = newnode(blocksym->a.label); i_dex = force_integer(topstack); /* Copy arexpr to array store */ for (; increment?i_dex->i.intval <= endloop: i_dex->i.intval >= endloop; increment?i_dex->i.intval++:i_dex->i.intval--) { evalbl_value_dup(result, blocksym); /*************************************************************** * Side effect on index * ***************************************************************/ { boolean result_shared = (result->data.val == i_dex); if (result_shared) setshared(i_dex); i_dex = force_integer(topstack); if (result_shared) clrshared(result->data.val); } /*************************************************************** * break * ***************************************************************/ if (stop_loop!=NULL || stop_fun!=NULL) { result->data.val= stop_loop!=NULL ? stop_loop : nothing ; break; } } stop_loop=stop_later; /* restore |break| switch */ return (object) result->data.val; } static object vid_for(endsym) symblst endsym; { return vid_for_a(endsym,true); } static object vid_downfor(endsym) symblst endsym; { return vid_for_a(endsym,false); } static object vid_forvec(vecsym) symblst vecsym; { index i, vecsize; object i_dex, vecobj; symblst result; symblst topstack = topsym->next; object stop_later=stop_loop; stop_loop = NULL; eval_value( vecsym); vecobj = vecsym->data.val; result = newnode(vecsym->next->a.label); i_dex = force_integer(topstack); vecsize = vecobj->v.ncomp; for (i = 0; i < vecsize; i++) { i_dex->i.intval = vecobj->v.compon[i]; evalbl_value_dup( result, vecsym->next); i_dex = force_integer(topstack); if (stop_loop!=NULL || stop_fun!=NULL) { result->data.val= stop_loop!=NULL ? stop_loop : nothing ; break; } } stop_loop=stop_later; return (object) result->data.val; } static object vid_format(matsym) symblst matsym; { index i, j, rowsize, colsize; object i_dex, matobj; symblst result; symblst topstack = topsym->next; object stop_later=stop_loop; eval_value( matsym); matobj = matsym->data.val; result = newnode(matsym->next->a.label); i_dex = topstack->data.val=(object) mkvector(matobj->m.ncols); /* i_dex has to be copied after assignment */ setshared(i_dex); stop_loop=NULL; rowsize = matobj->m.nrows; colsize = matobj->m.ncols; for (i = 0; i < rowsize; i++) { for (j = 0; j< colsize; j++) i_dex->v.compon[j] = matobj->m.elm[i][j]; evalbl_value_dup(result, matsym->next); if (type_of(topstack) != VECTOR) error("Vector expected - %s encountered\n", code_type(type_of(topstack))); if (stop_loop!=NULL || stop_fun!=NULL) { result->data.val= stop_loop!=NULL ? stop_loop : nothing ; break; } } stop_loop=stop_later; return (object) result->data.val; } static object arg_while_int_arg(condition) symblst condition; { symblst blocksym = condition->next; object stop_later=stop_loop; symblst cresult, bresult; stop_loop=NULL; cresult = newnode(condition->a.label); bresult = newnode(blocksym->a.label); while (stop_loop==NULL && stop_fun==NULL && (evalbl_value_dup(cresult, condition), Boolean(cresult->data.val))) evalbl_value_dup(bresult, blocksym); if (stop_loop!=NULL || stop_fun!=NULL) bresult->data.val= stop_loop!=NULL ? stop_loop : nothing; stop_loop=stop_later; return (object) bresult->data.val; } static object vid_eval(s) symblst s; { eval_value( s); return (object) NULL; } static object vid_void_arg(object x) { return (object) NULL; } static object vid_void(void) { return (object) NULL; } static object arg_nref_arg(s) object s; { Printf("nref: %d\n",s->i.nref); return s; } #ifdef development static object bin_addc_bin_int(a,b) object a,b; { bigint *result = (bigint*) a; addc(&result,Integer(b)); return (object) result; } static object bin_divc_bin_int(a,b) object a,b; { bigint *result = (bigint*) a; divc(&result,Integer(b)); return (object) result; } static object bin_mulc_bin_int(a,b) object a,b; { bigint *result = (bigint*) a; mulc(&result,Integer(b)); return (object) result; } #endif #ifdef where_object static object vid_showptr_tex(t) tekst *t; { int result = sscanf(t->string,"%x",&showptr); if (result != 1) error("%d pointers read instead of the expected one.\n",result); Printf("Message - if freeing pointer %lx\n",showptr); return (object) NULL; } static object vid_memcontrol_int(k) object k; { MEMCONTROL = Integer(k); return (object) NULL; } #endif object vid_gc(VOID) { gc(); return (object) NULL; } object vid_print(object x) { if (x!=NULL) switch (type_of(x)) { case INTEGER: printint(x); break; case VECTOR: if (lprint) print_vector(&x->v); else printvec(x); break; case MATRIX: if (lprint) print_matrix(&x->m); else print_mat_bars(&x->m); Printf("\n"); break; case GROUP: printgroup(x); break; case BIGINT: Printf("%*s",lmargin,""); printbigint(&x->b,0); Printf("\n"); break; case TEKST: printtekst(x); break; case POLY: { poly* p= &x->pl; if (!issorted(x)) p=Reduce_pol(p); if (lprint) print_poly(p); else print_poly_vertical(p); } } fflush(cur_out); return (object) NULL; } static object arg_sequence(symblst list) { symblst result; if (list==NULL) return (object) NULL; do { eval_value(list); result = list; if (list->class != VALUE) error("Sequence: system error.\n"); list = list->next; } while (list!=NULL && stop_loop==NULL && stop_fun==NULL); if (stop_loop!=NULL || stop_fun!=NULL) result->data.val=nothing; /* jumped out, no relevant result */ return result->data.val; } object inside_vid_assign(list,glob,update) symblst list; /* e.g., for 'm[i]=v': [m,v,i], for 'p|v=i': [p,i,v] */ boolean glob; fobject update; { /* 1 Calculate expression. 2 Clrshared `var` 3 Compute update(var, expression), */ symblst expr, foundsym; strtype name; /* save old value of |repair_obj|, which is defined in main.w */ object repair = repair_obj; object expr_obj; expr = list->next; /* the RHS */ name = list->a.label->name; /* name of LHS variable (without selectors) */ /* First evaluate the RHS */ eval_value( expr); expr_obj = expr->data.val; /* Then look up variable to be modified (which may be changed by the RHS) */ foundsym = srchsym(topsym, name, (symblst) NULL); if (foundsym && foundsym->class==OPERATOR) error("%s is a standard function." "Redefinition for same types is not allowed.\n" ,name_tab[foundsym->a.name]); repair_obj = foundsym?foundsym->data.val:(object) NULL; if (update!=NULL) { /*************************************************************** * Compute possible selectors of the LHS * ***************************************************************/ int count = 0; object obj[2]; symblst objlst; for (objlst = expr->next; objlst!=NULL; ++count,objlst=objlst->next) { if (count>= 2) error("System count. %d\n",count); eval_value(objlst); /*************************************************************** * Attention: no coercion of selectors * ***************************************************************/ obj[count] = objlst->data.val; } clrshared(repair_obj); /* to allow in situ update of variable */ clrshared(expr_obj); /* RHS will disappear in assignment */ /* This is where we really do the update: */ if (count == 1) expr_obj = (*(f3object)update)(repair_obj, expr_obj,obj[0]); else if (count == 2) expr_obj = (*(f4object)update)(repair_obj, expr_obj,obj[0],obj[1]); else if (count == 0) expr_obj = (*(f2object)update)(repair_obj, expr_obj); else error("System count. %d\n",count); expr->data.val = expr_obj; expr->type = type_of(expr_obj); setshared(expr_obj); } /* The following will be skipped if |update!=NULL|, because updating assignments may not have an undefined LHS (|error_not_foundsym| called) */ /* Now record newly defined variable, if applicable */ if (block_depth>0) { if ( !(glob && foundsym)) /* new local variable */ { symblst next = topsym->next; topsym->next = foundsym = newnode((labeltp) NULL); foundsym->formal = name; foundsym->next = next; } } else /* outermost evaluation level */ if (glob) { if (!foundsym) /* new global variable */ { symblst next = top_definitions->next; top_definitions->next = foundsym = creatsym(name); foundsym->next = next; } } else error("System: assignment.\n"); /* outermost cannot be local */ /*************************************************************** * ASIGNSYM * ***************************************************************/ repair_obj = foundsym?foundsym->data.val:(object) NULL; if (!update) clrshared(repair_obj); /* Bert Lisser 11-9-90 */ /* Lower refcount of value to be discarded in simple assignment */ if (repair_obj && (repair_obj != expr_obj)) { if (type_of(repair_obj)==POLY) { poly *hulp = (poly*) repair_obj; freepol(hulp); } else freemem(repair_obj); } if (type_of(expr_obj) == POLY && !issorted(expr_obj)) { expr->data.val = (object) Reduce_pol((poly*) expr_obj); if (expr->data.val != expr_obj) { clrshared(expr_obj); setshared(expr->data.val); } } assignsym(foundsym,expr); /* 21 -11 -90 */ expr->data.val = (object) NULL; /*************************************************************** * END ASSIGNSYM * ***************************************************************/ repair_obj = repair; return (object) NULL; } static object vid_assign(list) symblst list; { return inside_vid_assign(list,true,(fobject)NULL); } static object vid_assign_loc(list) symblst list; { return inside_vid_assign(list,false,(fobject)NULL); } static object mat_copy_mat_int_int_int_a (matrix* a,object e, object n1, object n2, boolean addassign) { index nrows, ncols; entry kval, lval, eval; matrix *result; nrows = a->nrows; ncols = a->ncols; kval = Integer(n1) - 1; lval = Integer(n2) - 1; if (kval < 0 || kval >= nrows) error("Row index (%ld) into matrix out of range. \n",(long)(kval+1)); if (lval < 0 || lval >= ncols) error("Column index (%ld) into matrix out of range. \n",(long)(lval+1)); result = isshared(a) ? copymatrix(a) :a; eval = Integer(e); if (addassign) *(*(result->elm + kval) + lval) += eval; else *(*(result->elm + kval) + lval) = eval; return (object) result; } static object mat_copy_mat_int_int_int (a,e,n1,n2) matrix *a; object n1, n2, e; { return mat_copy_mat_int_int_int_a(a, e, n1, n2, false); } static object mat_addassign_mat_int_int_int (a,e,n1,n2) matrix *a; object n1, n2, e; { return mat_copy_mat_int_int_int_a(a, e, n1, n2, true); } static object vec_copy_vec_int_int_a(a, e, n ,plusassign) vector* a; object n; object e; boolean plusassign; { index ncomp = a->ncomp; index kval; entry eval; vector *result; kval = Integer(n) - 1; if (kval < 0 || kval >= ncomp) error("Index (%ld) into vector out of range. \n", (long)(kval+1)); result = isshared(a) ? copyvector(a) : a ; eval = Integer(e); if (plusassign) result->compon[kval] += eval; else result->compon[kval] = eval; return (object) result; } static object vec_copy_vec_int_int(a, e, n) vector* a; object n, e; { return vec_copy_vec_int_int_a(a, e, n ,false); } static object vec_addassign_vec_int_int(a, e, n) vector* a; object n, e; { return vec_copy_vec_int_int_a(a, e, n ,true); } static object pol_copy_pol_bin_vec (a, e, v) poly* a; vector* v; object e; { index nrows = a->nrows; index nvars = a->ncols; index index1; poly *result; if (nvars != v->ncomp) error("%ld entries in update vector were required - %ld present.\n", (long)nvars,(long)v->ncomp); index1=searchterm(a,v->compon); if (index1>=0) { /* Update */ result = isshared(a) ? copypoly(a) : a ; clrshared(result->coef[index1]); } else { /* Add */ int i; entry *elm, *compon = v->compon; index1 = nrows; if (a->rowsize == a->nrows || isshared(a)) { setshared(a); result = extendpoly(a); clrshared(a); } else result = a; elm = result->elm[nrows]; for (i = 0;i < nvars; i++) elm[i] = compon[i]; result->nrows = nrows + 1; } if (type_of(e) == INTEGER) e = (object) entry2bigint(e->i.intval); result->coef[index1] = (bigint*) e; setshared(e); clrsorted(result); return (object) result; } static object mat_copy_mat_vec_int(matrix* a, vector * e, object n) { index nrows=a->nrows, ncols=a->ncols, ncomp=e->ncomp,kval=Integer(n)-1; matrix* result; if (kval < 0 || kval >= nrows) error("Row index (%ld) into matrix out of range. \n",(long)(kval+1)); if (ncomp != ncols) error("Size of vector is unequal to length of rows in matrix.\n"); result = isshared(a) ? copymatrix(a) : a ; copyrow(e->compon,result->elm[kval],ncomp); return (object) result; } static object pol_copy_pol_pol_int(poly* a, object e, object n) { index nrows=a->nrows, ncols=a->ncols; poly* ep=type_of(e)==INTEGER ? int2pol(&e->i) :type_of(e)==BIGINT ? bin2pol(&e->b) : &e->pl, * result; index ncomp = ep->ncols, kval=Integer(n)-1; if (ep->nrows!=1) error("Value to assign has %ld terms instead of one term)\n" ,(long)ep->nrows); if (kval<0 || kval >= nrows) error("Index (%ld) into polynomial out of range. \n",(long)(kval+1)); if (ncomp != ncols) error("Number variables in term and polynomial differ (%ld <-> %ld).\n", (long)ncomp,(long)ncols); result = isshared(a) ? copypoly(a) : a ; copyrow((ep->elm)[0],result->elm[kval],ncomp); clrshared(result->coef[kval]); result->coef[kval] = ep->coef[0]; setshared(result->coef[kval]); clrsorted(result); return (object) result; } static object vid_update_vec_int_int(list) symblst list; { return inside_vid_assign(list,true,vec_copy_vec_int_int); } static object vid_addassign_vec_int_int(list) symblst list; { return inside_vid_assign(list,true,vec_addassign_vec_int_int); } static object vid_update_mat_int_int_int(list) symblst list; { return inside_vid_assign(list,true,mat_copy_mat_int_int_int); } static object vid_addassign_mat_int_int_int(list) symblst list; { return inside_vid_assign(list,true,mat_addassign_mat_int_int_int); } static object vid_update_mat_vec_int(list) symblst list; { return inside_vid_assign(list,true,mat_copy_mat_vec_int); } static object vid_vecupdate_pol_bin_vec(list) symblst list; { return inside_vid_assign(list,true,pol_copy_pol_bin_vec); } static object vid_update_pol_pol_int(list) symblst list; { return inside_vid_assign(list,true,pol_copy_pol_pol_int); } static object vid_error_tex(s) object s; { error("%s\n",s->t.string); return (object) NULL; } static object int_eq_tex_tex(s,t) tekst*s,* t; { if (strcmp(s->string,t->string)) return (object) bool_false; return (object) bool_true; } static object tex_append_tex_tex(s,t) object s,t; { object result; short n= s->t.len,m= t->t.len; result=(object) mktekst(n+m); strcpy(result->t.string,s->t.string); strcat(result->t.string,t->t.string); return result; } static object tex_add_tex_bin(tekst* t, bigint* b) { string s = bigint2str(b); tekst *result = mktekst(t->len + strlen(s)); memcpy(result->string,t->string,t->len); strcpy(&result->string[t->len],s); freem(s); if (!isshared(t)) freemem(t); return (object) result; } static object tex_add_bin_tex(bigint* b,tekst* t) { string s = bigint2str(b); size_t l= (int) strlen(s); tekst *result = mktekst(t->len+l); strcpy(result->string,s); strcpy(&result->string[l],t->string); freem(s); if (!isshared(t)) freemem(t); return (object) result; } static object tex_add_tex_vec(tekst* t, vector* v) { size_t l=1+v->ncomp; index i; char buf[20]; tekst *result; char* p; if (v->ncomp==0) l=2; else for (i=0; incomp; ++i) l+=sprintf(buf,"%ld",(long)v->compon[i]); result=mktekst(t->len+l); memcpy(result->string,t->string,t->len); p=&result->string[t->len]; *p++='['; if (v->ncomp>0) p+=sprintf(p,"%ld",(long)v->compon[0]); for (i=1; incomp; ++i) p+=sprintf(p,",%ld",(long)v->compon[i]); strcpy(p,"]"); if (!isshared(t)) freemem(t); return (object) result; } static object tex_add_vec_tex(vector* v, tekst* t) { size_t l=1+v->ncomp; index i; char buf[20]; tekst *result; char* p; if (v->ncomp==0) l=2; else for (i=0; incomp; ++i) l+=sprintf(buf,"%ld",(long)v->compon[i]); result=mktekst(t->len+l); p=result->string; *p++='['; if (v->ncomp>0) p+=sprintf(p,"%ld",(long)v->compon[0]); for (i=1; incomp; ++i) p+=sprintf(p,",%ld",(long)v->compon[i]); *p++=']'; strcpy(p,t->string); if (!isshared(t)) freemem(t); return (object) result; } static object tex_add_tex_grp(tekst* t, group* g) { string grp_txt = grp2str(g); int n = (int)strlen(grp_txt); tekst *result = mktekst(t->len + n); memcpy(result->string,t->string,t->len); strcpy(&result->string[t->len],grp_txt); if (!isshared(t)) freemem(t); freem(grp_txt); return (object) result; } static object tex_add_grp_tex( group* g, tekst* t) { string grp_txt = grp2str(g); size_t l = (int)strlen(grp_txt); tekst *result = mktekst(t->len + l); strcpy(result->string,grp_txt); strcpy(&result->string[l],t->string); if (!isshared(t)) freemem(t); freem(grp_txt); return (object) result; } static object tex_mul_tex_int(t,d) tekst* t; intcel* d; { entry n = d->intval; index i; tekst *result = mktekst(n * t->len); if (n <= 0) error ("Negative value of multiplier for text is not allowed.\n"); result->string[0] = '\0'; for (i=0;istring,t->string); if (!isshared(t)) freemem(t); return (object) result; } static object tex_mul_int_tex(intcel* d,tekst* t) { return tex_mul_tex_int(t,d); } static object tex_fmt_bin_int(b,d) bigint* b; intcel* d; { int w = (int)d->intval; string s = bigint2str(b); int n = (int)strlen(s),i; boolean left = (w < 0); int width = abs(w); tekst *result; char *str; if (n > width) width = n; result = mktekst(width); str = result->string; for (i=0;i < width; i++) str[i] = ' '; if (left) strcpy(str,s); else strcpy(str+(width-n),s); freem(s); return (object) result; } static object vid_addr(o) object o; { Printf("%s: address = %p\n",code_type(type_of(o)),o); return (object) NULL; } static object pol_addc_pol_pol(a,p) object a,p; { object result; index m = a->pl.nrows, n = a->pl.ncols, mp = p->pl.nrows; index i,j,k; bigint *coef; if (type_of(p) == INTEGER) p = (object) (*int2pol)(&p->i); else if (type_of(p) == BIGINT) p = (object) (*bin2pol)(&p->b); if (n != p->pl.ncols) error("Number of indeterminates unequal (%ld <-> %ld).\n", (long)n,(long)p->pl.ncols); if (isshared(a) || (m + mp) > a->pl.rowsize) { result = (object) mkpoly(2 * m + mp, n); result->pl.nrows = m; for (i = 0; i < m; i++) { for (j = 0; j < n; j++) *(*(result->pl.elm + i)+j) = *(*(a->pl.elm + i)+j); coef = a->pl.coef[i]; result->pl.coef[i] = coef; setshared(coef); } } else result = a; /*************************************************************** * Add new polynomial * ***************************************************************/ for (i = 0, k = m; i < mp; i++,k++) { for (j = 0; j < n; j++) *(*(result->pl.elm + k)+j) = *(*(p->pl.elm + i) + j); coef = p->pl.coef[i]; result->pl.coef[k] = coef; setshared(coef); } result->pl.nrows = m + mp; clrsorted(result); return result; } static object vid_addupdate_vec_int(list) symblst list; { return inside_vid_assign(list,true,vec_addelm_vec_int); } static object vid_addupdate_mat_vec(list) symblst list; { return inside_vid_assign(list,true,mat_add_mat_vec); } static object vid_addupdate_mat_mat(list) symblst list; { return inside_vid_assign(list,true,mat_add_mat_mat); } static object vid_addupdate_vec_vec(list) symblst list; { return inside_vid_assign(list,true,vec_add_vec_vec); } static object vid_addupdate_pol_pol(list) symblst list; { return inside_vid_assign(list,true,pol_addc_pol_pol); } static object vid_addupdate_tex_tex(list) symblst list; { return inside_vid_assign(list,true,tex_append_tex_tex); } static object vid_addupdate_tex_bin(list) symblst list; { return inside_vid_assign(list,true,tex_add_tex_bin); } #ifndef NOSAVEMAT static object vid_writemat_mat_grp_tex(m,g,t) object m; group *g; tekst *t; { Objectwrite(m,g,t->string); return (object) NULL; } static object vid_writestring_tex_grp_tex(s,g,t) object s; group *g; tekst *t; { Objectwrite(s,g,t->string); return (object) NULL; } static object mat_readmat_grp_tex(g,t) group *g; tekst *t; { return Objectread(g,t->string); } static object tex_readstring_grp_tex(g,t) group *g; tekst *t; { return Objectread(g,t->string); } #endif static object mat_getmat_tex(t) tekst* t; { return Objectget(t->string); } static object tex_getstring_tex(t) tekst* t; { return Objectget(t->string); } static object vid_savemat_mat_tex(m,t) object m; tekst* t; { Objectsave(m,t->string); return (object) NULL; } static object vid_savestring_tex_tex(s,t) object s; tekst* t; { Objectsave(s,t->string); return (object) NULL; } /* * Write here the interfaces above defined operations. */ Symbrec static4[] = { M2(".forint", vid_for, ARGTYPE, INTEGER, ARGTYPE) M2(".downforint", vid_downfor, ARGTYPE, INTEGER, ARGTYPE) M2(".forvec", vid_forvec, ARGTYPE, VECTOR, ARGTYPE) M2(".format", vid_format, ARGTYPE, MATRIX, ARGTYPE) M2(".whilefun", arg_while_int_arg, ARGTYPE, INTEGER, ARGTYPE) M2(".whilefun", arg_while_int_arg, ARGTYPE, VECTOR, ARGTYPE) M2(".whilefun", arg_while_int_arg, ARGTYPE, MATRIX, ARGTYPE) M2(".whilefun", arg_while_int_arg, ARGTYPE, POLY, ARGTYPE) M1(".sequence", arg_sequence, ARGTYPE, ARGLST) M1("eval", vid_eval, VOID, VOID) C0("gcol", vid_gc, VOID) C1("print", vid_print, VOID, ARGTYPE) C1("addr", vid_addr, VOID, ARGTYPE) C1("void", vid_void_arg, VOID, ARGTYPE) C0("_vid", vid_void, VOID) C1("nref", arg_nref_arg, ARGTYPE, ARGTYPE) C2("_on",vid_on_int_tex,VOID,INTEGER, TEKST) C2("_off",vid_off_int_tex,VOID,INTEGER, TEKST) C0("_on",vid_on, VOID) C0("_off",vid_on, VOID) C0("save_options",vid_save, VOID) C0("restore_options",vid_restore, VOID) #ifdef where_object C1("showptr", vid_showptr_tex, VOID, TEKST) C1("memcontrol", vid_memcontrol_int, VOID, INTEGER) C2("addc",bin_addc_bin_int,BIGINT,BIGINT,INTEGER) C2("divc",bin_divc_bin_int,BIGINT,BIGINT,INTEGER) C2("mulc",bin_mulc_bin_int,BIGINT,BIGINT,INTEGER) #endif C1("error", vid_error_tex, VOID, TEKST) M2(".assign", vid_assign, VOID, VOID, ARGTYPE) M2(".assign_loc", vid_assign_loc, VOID, VOID, ARGTYPE) M3(".update", vid_update_vec_int_int, VOID, VECTOR, INTEGER, INTEGER) M3(".add_and_assign", vid_addassign_vec_int_int, VOID, VECTOR, INTEGER, INTEGER) M4(".update", vid_update_mat_int_int_int, VOID, MATRIX, INTEGER, INTEGER, INTEGER) M4(".add_and_assign", vid_addassign_mat_int_int_int, VOID, MATRIX, INTEGER, INTEGER, INTEGER) M3(".update", vid_update_mat_vec_int, VOID, MATRIX, VECTOR, INTEGER) M3(".vecupdate", vid_vecupdate_pol_bin_vec, VOID, POLY, BIGINT, VECTOR) M3(".update", vid_update_pol_pol_int, VOID, POLY, POLY, INTEGER) M2(".+=",vid_addupdate_vec_int, VOID,VECTOR,INTEGER) M2(".+=",vid_addupdate_mat_vec, VOID,MATRIX,VECTOR) M2(".+=",vid_addupdate_mat_mat, VOID,MATRIX,MATRIX) M2(".+=",vid_addupdate_vec_vec, VOID,VECTOR,VECTOR) M2(".+=",vid_addupdate_pol_pol, VOID,POLY,POLY) M2(".+=",vid_addupdate_tex_tex, VOID,TEKST,TEKST) M2(".+=",vid_addupdate_tex_bin, VOID,TEKST,BIGINT) C2("==",int_eq_tex_tex,INTEGER,TEKST,TEKST) C2("^",tex_append_tex_tex,TEKST,TEKST,TEKST) C2("+",tex_append_tex_tex,TEKST,TEKST,TEKST) C2("+",tex_add_tex_bin,TEKST,TEKST,BIGINT) C2("+",tex_add_bin_tex,TEKST,BIGINT,TEKST) C2("+",tex_add_tex_grp,TEKST,TEKST,GROUP) C2("+",tex_add_grp_tex,TEKST,GROUP,TEKST) C2("+",tex_add_tex_vec,TEKST,TEKST,VECTOR) C2("+",tex_add_vec_tex,TEKST,VECTOR,TEKST) C2("*",tex_mul_int_tex,TEKST,INTEGER,TEKST) C2("*",tex_mul_tex_int,TEKST,TEKST,INTEGER) C2("fmt",tex_fmt_bin_int,TEKST,BIGINT,INTEGER) #ifndef NOSAVEMAT C3("write_mat",vid_writemat_mat_grp_tex,VOID,MATRIX,GROUP,TEKST) C3("write_string",vid_writestring_tex_grp_tex,VOID,TEKST,GROUP,TEKST) C2("read_mat",mat_readmat_grp_tex,MATRIX,GROUP,TEKST) C2("read_string",tex_readstring_grp_tex,TEKST,GROUP,TEKST) #endif C2("save_mat",vid_savemat_mat_tex,VOID,MATRIX,TEKST) C2("save_string",vid_savestring_tex_tex,VOID,TEKST,TEKST) C1("get_mat",mat_getmat_tex,MATRIX,TEKST) C1("get_string",tex_getstring_tex,TEKST,TEKST) }; int nstatic4 = array_size(static4); fobject seqfun = arg_sequence; LiE/static/static5.c0000644000175000017500000000573607120142601013470 0ustar hakanhakan/* Static5 is engaged with type BIGINT and ggd(vec) */ #include "lie.h" #ifdef __STDC__ static entry gcd(entry x,entry y); static entry abs_minimum(vector* v_vec); static boolean equal_elements(vector* v_vec); #endif static bigint* bin_from_int(i) intcel* i; { entry k = i->intval; freemem(i); return entry2bigint(k); } static intcel* int_from_bin(b) bigint* b; { entry k = bigint2entry(b); freemem(b); return mkintcel(k); } static object vid_factor_bin(b) object b; { return (object) Factor((bigint *) b); } /* Transform a vector into a matrix with the same components as the vector, when read by rows */ static object mat_matvec_vec_int(object v,object nrows_object) { index size=v->v.ncomp, nrows, ncols=nrows_object->i.intval; if (ncols<=0) error("Number of columns should be positive.\n"); if (size%ncols!=0) error ("Number of columns should divide size of vector.\n"); { matrix* m=mkmatrix(nrows=size/ncols,ncols); index i,j,k=0; for (i=0; ielm[i][j]=v->v.compon[k++]; /* |k==ncols*i+j| before increment */ return (object) m; } } static entry gcd(x,y) entry x,y; { /* Requirement 0ncomp; entry* v = v_vec->compon; index minimum=0; for (i=0; incomp; entry* v = v_vec->compon; /* Omit prefixed 0 */ while (first < n && v[first]==0) first++; if (first == n) return true; /* All zero */ i = first + 1; while (i < n && (v[i]== 0 || labs(v[first]) == labs(v[i]))) i++; if (i == n) return true; return false; } object int_gcd_vec(v_vec) vector *v_vec; { entry r = abs_minimum(v_vec); entry *v; index i; index n = v_vec->ncomp; if (isshared(v_vec)) v_vec = copyvector(v_vec); v = v_vec->compon; while (!equal_elements(v_vec)) { for (i=0;ii.intval)); return (result); } static object int_min_int(a) object a; { if (isshared(a)) return (object) mkintcel(-a->i.intval); else { a->i.intval = -a->i.intval; return a; } } static object int_lt_int_int(a, b) object a, b; { boolean crit = (a->i.intval < b->i.intval); freemem(a);freemem(b); if (crit) return (object) bool_true; return (object) bool_false; } static object int_gt_int_int(a, b) object a, b; { boolean crit = (a->i.intval > b->i.intval); freemem(a);freemem(b); if (crit) return (object) bool_true; return (object) bool_false; } static object int_le_int_int(a, b) object a, b; { boolean crit = (a->i.intval <= b->i.intval); freemem(a);freemem(b); if (crit) return (object) bool_true; return (object) bool_false; } static object int_ge_int_int(a, b) object a, b; { boolean crit = (a->i.intval >= b->i.intval); freemem(a);freemem(b); if (crit) return (object) bool_true; return (object) bool_false; } static object int_eq_int_int(a, b) object a, b; { boolean crit = (a->i.intval == b->i.intval); freemem(a);freemem(b); if (crit) return (object) bool_true; return (object) bool_false; } static object int_ne_int_int(a, b) object a, b; { boolean crit = (a->i.intval != b->i.intval); freemem(a);freemem(b); if (crit) return (object) bool_true; return (object) bool_false; } static object int_add_int_int(a, b) object a, b; { object result; result = (object) mkintcel(a->i.intval + b->i.intval); return (result); } static object int_dif_int_int(a, b) object a, b; { object result; result = (object) mkintcel(a->i.intval - b->i.intval); return (result); } static object int_mul_int_int(a, b) object a, b; { object result; result = (object) mkintcel(a->i.intval * b->i.intval); return (result); } static object int_div_int_int(object a, object b) { if (b->i.intval==0) error("Division by zero.\n"); return (object) mkintcel(a->i.intval / b->i.intval); } static object int_mod_int_int(object a, object b) { entry x = a->i.intval,n=b->i.intval; if (n <= 0) error("Modulus must be positive number.\n"); return (object) mkintcel(x>=0?x%n:((-x)%n==0?0:n-((-x)%n))); } static object addupdate_int_int(a,b) object a,b ; { object result; if (type_of(a) == BIGINT || isshared(a)) result = (object) mkintcel(Integer(a)); else result = a; result -> i.intval += Integer(b); return result; } static object vid_addupdate_int_int(list) symblst list; {return inside_vid_assign(list,true,addupdate_int_int);} Symbrec static6[] = { C1("abs", int_abs_int, INTEGER, INTEGER) C2("==", int_eq_int_int, INTEGER, INTEGER, INTEGER) C2("!=", int_ne_int_int, INTEGER, INTEGER, INTEGER) C2("<=", int_le_int_int, INTEGER, INTEGER, INTEGER) C2(">=", int_ge_int_int, INTEGER, INTEGER, INTEGER) C2("<", int_lt_int_int, INTEGER, INTEGER, INTEGER) C2(">", int_gt_int_int, INTEGER, INTEGER, INTEGER) C1("-", int_min_int, INTEGER, INTEGER) C2("+", int_add_int_int, INTEGER, INTEGER, INTEGER) C2("-", int_dif_int_int, INTEGER, INTEGER, INTEGER) C2("*", int_mul_int_int, INTEGER, INTEGER, INTEGER) C2("/", int_div_int_int, INTEGER, INTEGER, INTEGER) C2("%", int_mod_int_int, INTEGER, INTEGER, INTEGER) M2(".+=",vid_addupdate_int_int, VOID,INTEGER,INTEGER) }; int nstatic6 = array_size(static6); LiE/static/static7.c0000644000175000017500000001001606760533161013473 0ustar hakanhakan#include "lie.h" static object bin_abs_bin(a) object a; { object result; result = (object) copybigint((bigint*) a, (bigint*) NULL); result->b.size = abs(result->b.size); return (result); } static object bin_min_bin(a) object a; { object result; if (isshared(a)) result = (object) copybigint((bigint*) a, NULL); else result = a; result->b.size = -result->b.size; return (result); } static object int_lt_bin_bin(a, b) object a, b; { boolean crit = (cmp((bigint*) a,(bigint*) b) < 0); freemem(a);freemem(b); if (crit) return (object) bool_true; return (object) bool_false; } static object int_gt_bin_bin(a, b) object a, b; { boolean crit = (cmp((bigint*) a,(bigint*) b) > 0); freemem(a);freemem(b); if (crit) return (object) bool_true; return (object) bool_false; } static object int_le_bin_bin(a, b) object a, b; { boolean crit = (cmp((bigint*) a,(bigint*) b) <= 0); freemem(a); freemem(b); if (crit) return (object) bool_true; return (object) bool_false; } static object int_ge_bin_bin(a, b) object a, b; { boolean crit = (cmp((bigint*) a,(bigint*) b) >= 0); freemem(a);freemem(b); if (crit) return (object) bool_true; return (object) bool_false; } static object int_eq_bin_bin(a, b) object a, b; { boolean crit = cmp((bigint*) a,(bigint*) b); freemem(a); freemem(b); if (!crit) return (object) bool_true; return (object) bool_false; } static object int_ne_bin_bin(a, b) object a, b; { boolean crit = cmp((bigint*) a,(bigint*) b); freemem(a); freemem(b); if (crit) return (object) bool_true; return (object) bool_false; } static object bin_add_bin_bin(a,b) object a,b; { return (object) add((bigint*) a , (bigint*) b); } static object bin_sub_bin_bin(a,b) object a,b; { return (object) sub((bigint*) a , (bigint*) b); } static object bin_mul_bin_bin(a,b) object a,b; { return (object) mult((bigint*) a,(bigint*) b); } static object bin_div_bin_bin(a,b) object a,b; { return (object) quotient((bigint*) a,(bigint*) b); } static object bin_mod_bin_bin(a,b) object a,b; { return (object) mod((bigint*) a,(bigint*) b); } static object addupdate_bin_bin(a,b) object a,b ; { bigint* c,* d,* result; setshared(a); if (type_of(a) == INTEGER) c = (*int2bin)(&a->i); else c = (bigint*) a; if (type_of(b) == INTEGER) d = (*int2bin)(&b->i); else d = (bigint*) b; result = add(c,d); clrshared(a); return (object) result; } static object vid_addupdate_bin_bin(list) symblst list; {return inside_vid_assign(list,true,addupdate_bin_bin);} #ifdef development static object bin_addc_bin_int(a,b) bigint *a; intcel *b; { addc(&a,b->intval); return (object) a; } static object bin_mulc_bin_int(a,b) bigint *a; intcel *b; { mulc(&a,b->intval); return (object) a; } static object bin_divc_bin_int(a,b) bigint *a; intcel *b; { divc(&a,b->intval); return (object) a; } #endif Symbrec static7[] = { C1("abs", bin_abs_bin, BIGINT, BIGINT) C1("-", bin_min_bin, BIGINT, BIGINT) C2("==", int_eq_bin_bin, INTEGER, BIGINT, BIGINT) C2("!=", int_ne_bin_bin, INTEGER, BIGINT, BIGINT) C2("<=", int_le_bin_bin, INTEGER, BIGINT, BIGINT) C2(">=", int_ge_bin_bin, INTEGER, BIGINT, BIGINT) C2("<", int_lt_bin_bin, INTEGER, BIGINT, BIGINT) C2(">", int_gt_bin_bin, INTEGER, BIGINT, BIGINT) C2("+", bin_add_bin_bin, BIGINT, BIGINT, BIGINT) C2("-", bin_sub_bin_bin, BIGINT, BIGINT, BIGINT) C2("*",bin_mul_bin_bin,BIGINT,BIGINT,BIGINT) C2("/",bin_div_bin_bin,BIGINT,BIGINT,BIGINT) C2("%",bin_mod_bin_bin,BIGINT,BIGINT,BIGINT) M2(".+=",vid_addupdate_bin_bin, VOID,BIGINT,BIGINT) #ifdef development C2("addc",bin_addc_bin_int, BIGINT, BIGINT, INTEGER) C2("mulc",bin_mulc_bin_int, BIGINT, BIGINT, INTEGER) C2("divc",bin_divc_bin_int, BIGINT, BIGINT, INTEGER) #endif }; int nstatic7 = array_size(static7); LiE/title0000664000175000017500000000003507072132367011530 0ustar hakanhakanFree source code distributionLiE/util/0002775000175000017500000000000007072645170011446 5ustar hakanhakanLiE/util/Makefile0000664000175000017500000000034507072645170013106 0ustar hakanhakanCINCLUDES=-I.. -I../box .SUFFIXES: %.o: %.c $(CC) -c $(CPPFLAGS) $(all-C-flags) $< all: ../infoind ../learnind ../learnind: learnind.o $(CC) -o ../learnind learnind.o ../infoind: infoind.o $(CC) -o ../infoind infoind.o LiE/util/infoind.c0000644000175000017500000001144507073056611013236 0ustar hakanhakan/* This program produces an index file where the indexes point to the text belonging to the keywords. This program have to be executed after each update of the file INFOFILE */ #include "lie.h" #define BUFSIZE 2048 #define INDEXFIL "INFO.ind" #define INFOFIL "INFO" #define KEYCHAR '@' #define NEWLINE '\n' #define OPEN '(' #define CLOSE ')' objtype type_code(char* name) { if (!strncmp(name, "int",3)) return (INTEGER); if (!strncmp(name, "vec",3)) return (VECTOR); if (!strncmp(name, "mat",3)) return (MATRIX); if (!strncmp(name, "grp",3)) return (GROUP); if (!strncmp(name, "vid",3)) return (VOID); if (!strncmp(name, "tex",3)) return (TEKST); if (!strncmp(name, "bin",3)) return (BIGINT); if (!strncmp(name, "pol",3)) return (POLY); return (ERROR); } static void make_key(char* start,char* key) { if (strlen(start) >= KEYWORDLEN) { strncpy(key,start,KEYWORDLEN-1); key[KEYWORDLEN-1] = '\0'; printf("Key \"%s\" truncated\n to \"%s\".\n",start,key); } else strcpy(key,start); } /* scan any parents specified after CLOSE in heading of function */ static void add_parents(char* start,info_index_tp* inf) { int i=0; char* pt=strchr(start,KEYCHAR); char key[KEYWORDLEN]; if (start[0]=='\0') /* NEWLINE directly after CLOSE */ { inf->directory=false; inf->parents.n=0; return; } if (pt==start) /* KEYCHAR directly after CLOSE */ { inf->directory=true; inf->parents.n=0; return; } while (iparents.p[i++],key); pt=strchr(start=pt+1,KEYCHAR); } if (strlen(start)>0) /* last name not followed by KEYCHAR: the key is not a dir */ { if (iparents.p[i],key); inf->directory=false; ++i; } else { printf("Maximum number of parents (=%d) exceeded.\n",i); exit(1); } } else inf->directory=true; inf->parents.n=i; } int main(void) { char indexfil[LABELLENGTH]; char infofil[LABELLENGTH]; char buf[BUFSIZE+1]; char key[KEYWORDLEN]; long number_chars_read; int i,count=0; FILE *indexpt,*infopt; info_index_tp info; /* current info record */ strcpy(indexfil,INDEXFIL); indexpt=fopen(indexfil,writemode); if (indexpt==NULL) { printf("File %s cannot be written.\n",indexfil); exit(1); } for (i=0; i=0) /* skip the first time around */ { strcpy(info.keyword,key); info.start=file_adress+location_start; info.size =location_end-location_start; info.seq=i; count++; fwrite(&info,sizeof(info_index_tp),1,indexpt); /* write record */ } /* Scan for new key. Pattern: ... ( ... ) ... \n */ if ( (bufpt_open=strchr(bufpt,OPEN))==NULL || (bufpt_close=strchr(bufpt_open,CLOSE))==NULL || (bufpt_newline=strchr(bufpt,NEWLINE))==NULL ) continue; /* no complete header line present in buffer */ *bufpt_open='\0'; make_key(bufpt+1,key); *bufpt_open=OPEN; bufpt=bufpt_open; if (bufpt[1]==CLOSE) { info.narg=0; bufpt++; } /* @f() */ else /* scan types */ { int k=0; while (k<6 && (*bufpt!=CLOSE)) { info.t[k++]=type_code(++bufpt); bufpt=(bufpt+3); } /* each type has EXACTLY 3 characters, separator is not read */ info.narg=k; } if (*bufpt != CLOSE) { printf("Too many arguments (=%d) found for %s\n" ,info.narg,key); exit(1); } bufpt=bufpt_newline+1; location_start=bufpt-buf; /* advance to next line */ do --bufpt_newline; while (isspace(*bufpt_newline)); /* erases CR */ *++bufpt_newline='\0'; add_parents(bufpt_close+1,&info); } /* end of key scanning loop */ file_adress=file_adress + location_end; bufpt_newline=bufpt=bufpt_close=bufpt_open=buf; if (number_chars_read=0 && (number_chars_read=fread(buf,sizeof(*buf),BUFSIZE,learnpt))!=0) { buf[number_chars_read]='\0'; location_start=-1; while ((bufpt=strchr(bufpt,KEYCHAR))!=0 && bufpt_newline!=NULL) { location_end=bufpt-buf; if (location_start>=0) /* skip the first time around */ { strcpy(learn.keyword,key); learn.start=file_adress+location_start; learn.size=location_end-location_start; ++count; fwrite(&learn,sizeof(learn_index_tp),1,indexpt); /* write record */ } /* Scan for new key. Pattern: ... \n */ if (bufpt!=NULL && (bufpt_newline=strchr(bufpt,NEWLINE))!=NULL) { location_start=bufpt_newline+1-buf; /* beginning of next line */ do --bufpt_newline; while (isspace(*bufpt_newline)); /* erases CR */ *++bufpt_newline='\0' ; if (strlen(bufpt+1) >= KEYWORDLEN) { strncpy(key,bufpt+1,KEYWORDLEN-1); key[KEYWORDLEN-1]='\0'; printf("Key \"%s\" truncated\n to \"%s\".\n",bufpt+1,key); } else strcpy(key,bufpt+1); bufpt=&buf[location_start]; } } file_adress=file_adress+location_end; bufpt_newline=bufpt=buf; if (number_chars_readnrows; poly* result=private_pol(p); bigint** b; for (i=0; icoef[i],isshared(*b)>1) { clrshared(*b); *b=copybigint(*b,NULL); setshared(*b); } return result; } poly* Alt_dom(poly* p) { index j,s=Ssrank(grp); /* keep out of torus */ if (!s) return p; p=thorough_copy(p); for (j=0; jnrows; j++) { register index i=0,n=0; entry* v=p->elm[j]; bigint* c=p->coef[j]; while(true) { while (v[i]>=0) if (++i==s) goto finish_j; /* find negative entry */ if (++v[i]==0) { c->size=0; break; } /* kill term, forget exponent */ w_refl(v,i); n++; v[i]--; /* reflect, count and shift back */ i-=(i<2 ? i : 2); /* go back to first entry that might be negative */ } finish_j: if (n%2) c->size= -c->size; } return Reduce_pol(p); } /* the follwing code is largely copied (with permission) from weyl.c, which is now incorporated into weyl.w; shortly, thid file will be assimilated too */ /* This routine is large because we have taken the tests out of the loops */ #define loop(body) while (n-->0) \ { if (b= *c++,(d= *(v=(*m++)+k)+1)<0) { b->size= -b->size; body; *v= -1-d; }} /* OK this is tricky, and we have to refrain from using the comma-operator in the body. But unless we slip in a closing brace after the body, we will be in if-else matching problems */ static void simp_alt_refls(poly* p,index offset, index i,simpgrp* g) { bigint** c=p->coef; entry** m=p->elm; index n=p->nrows,j,k=offset+i,r=g->lierank; entry d,* v; bigint* b; for (j=0; jnrows=n; switch (g->lietype) { case 'A': if (i>0 && i0 && i0 && i0 && i3 && is); else if (simpgroup(grp)) simp_alt_refls(p,0,nr,Liecomp(grp,0)); else { index i,d,offset=0; for (i=0; nr>=(d=Liecomp(grp,i)->lierank); i++) { offset+=d; nr-=d; } simp_alt_refls(p,offset,nr,Liecomp(grp,i)); } } poly* Alt_dom_w(poly* p, vector* word) { index i; entry* w=word->compon,wi; p=thorough_copy(p); for (i=0; incomp; i++) if((wi=w[i])!=0) alt_refls(p,wi-1); return p; } /* For Demazure we shall employ an ordering not used elsewhere, namely by first comparing one specific position, and if that is not decisive the remaining positions lexicographically */ static index maindex; static cmp_tp main_decr(entry* v, entry* w, index len) { if (v[maindex]!=w[maindex]) return v[maindex]>w[maindex] ? 1 : -1; while (len-->0) if (*v++!= *w++) return *--v > *--w ? 1 : -1; return 0; } static poly* demaz(poly* p,index nr) { index i,k=0,pos,r=p->ncols,upb_size=0; poly* result; matrix* cart=Cartan(); entry* root=cart->elm[nr],* x=mkintarray(r); cmpfn_tp sav_cmp=cmpfn; cmpfn=main_decr; maindex=nr; alt_refls(p,nr); /* start by trying to cancel */ for (i=0; inrows; i++) upb_size+=p->elm[i][nr]+1; result=mkpoly(upb_size,r); for (i=0; inrows; i++) if (p->coef[i]) /* terms may get cancelled */ { bigint* c=p->coef[i]; copyrow(p->elm[i],x,r); p->coef[i]=NULL; clrshared(c); do { copyrow(x,result->elm[k],r); result->coef[k++]=c; setshared(c); if (x[nr]==0) break; /* stop when reflection hyperplane is reached */ copyrow(x,result->elm[k],r); result->coef[k]=c; setshared(c); w_refl(result->elm[k++],nr); /* add weight reflected in hyperplane */ add_xrow_to(x,-1,root,r); if (x[nr]<0) break; /* stop if reflection hyperplane is passed */ if ((pos=searchterm(p,x))>=0) { clrshared(p->coef[pos]); c=add(c,p->coef[pos]); p->coef[pos]=NULL; } } while (c->size!=0); /* stop if coefficients cancel exactly */ } freemem(p); /* coeff's already discarded */ freemem(cart); freearr(x); cmpfn=sav_cmp; result->nrows=k; return result; /* terms are distinct but not sorted */ } poly* Demazure(poly* p, vector* word) { index i; for (i=0; incomp; i++) p=demaz(thorough_copy(p),word->compon[i]-1); return p; } LiE/box/branch.c0000644000175000017500000001463407107767171012673 0ustar hakanhakan#include "lie.h" #ifdef __STDC__ static void add_spec_wt(entry* v); static poly* simp_spec_irr(entry* lambda,entry* t,simpgrp* g); static poly* spec_irr(entry* lambda,entry* t,object G); static void add_branch_wt(entry* v); static poly* simp_branch_irr(entry* lambda,entry** m,simpgrp* g); static poly* branch_irr(entry* lambda,entry** m,object G); #endif static index r; /* the lie rank of the (main) group */ static entry* h; /* the semisimple element whose spectrum is analysed */ static entry ord; /* the order of the semisimple element */ static bigint** spec; /* the coefficients accumulating the spectrum */ static bigint* multi; /* multiplicity for add_spec_wt and add_branch_wt */ /* the call of Weylloop below repeatedly calls on the following procedure `add_spec_wt', with `v' referring to a weight in the current Weyl orbit */ static void add_spec_wt(v) entry* v; { entry i=inprow(v,h,r)%ord; if (i<0) i+=ord; { bigint** c=spec+i; clrshared(*c); *c=add(*c,multi); setshared(*c); } } /* compute multiplicities of the ord different eigenvalues of toral_elt (namely $e^{2k\pi i/ord}$ for k=0,..,ord-1, where toral_elt is an element of the torus of order ord = toral_elt[r]) on module of weight lambda */ static poly* simp_spec_irr(lambda,t,g) entry* lambda,* t; simpgrp* g; { poly* domchar=simp_domchar(lambda,NULL,g),* result=mkpoly(ord,1); index i; Weylloopinit(g); r=g->lierank; h=t; spec=result->coef; for (i=0; ielm[i][0]=i; } for (i=0; inrows; i++) /* traverse all dominant weights */ { multi=domchar->coef[i]; Weylloop(add_spec_wt,domchar->elm[i]); /* collect induced dominant weights */ } freepol(domchar); Weylloopexit(); return result; } static poly* spec_irr(lambda,t,G) entry* lambda,* t; object G; { index i,j,S=Ssrank(G),td=G->g.toraldim; poly* x; entry exp; lambda+=S; t+=S; x=mkpoly(1,1); *x->coef=one; exp=inprow(lambda,h,td)%ord; if (exp<0) exp+=ord; x->elm[0][0]=exp; for (i=G->g.ncomp-1; i>=0; i--) { simpgrp* g=Liecomp(G,i); index d=g->lierank; lambda-=d; t-=d; x=Mul_pol_pol(simp_spec_irr(lambda,t,g),x); /* tensor in T1 */ for (j=0; jnrows; j++) x->elm[j][0] %=ord; x=Reduce_pol(x); } return x; } poly* Spectrum(p,toral_elt) poly* p; vector* toral_elt; { entry* t=toral_elt->compon,** lambda=p->elm; index i,r=toral_elt->ncomp-1; poly* result=poly_null(1); ord=t[r]; /* initialise ord once and for all */ for (i=0; inrows; i++) /* lambda= &(p->elm[i]) */ result=Addmul_pol_pol_bin(result,spec_irr(*lambda++,t,grp),p->coef[i]); return result; } static index rsub /* the lie rank of the "sub" group */ , ssub; /* the semisimple rank of the "sub" group */ static entry** resmat /* m->elm */ ,* add_wt; /* induced weigth on h, used by add_branch_wt */ /* Branching is calculated as follows. First the dominant weights and their multiplicities are calculated in the "source" group `g' by Freudenthals recursion. Then for each dominant weight found its Weyl orbit is traversed, and to all weigths so obtained the linear map `m' is applied to obtain a weight for the "destination" group `h'. Then those image weights that are dominant (for `h') are col- lected, and the result is decomposed as a sum of modules by `char_decomp'. */ /* the call of Weylloop below repeatedly calls on the following procedure `add_branch_wt', with `v' referring to a weight in the current Weyl orbit */ static void add_branch_wt(v) entry* v; { register index i; mulvecmatelm(v,resmat,add_wt,r,rsub); /* add_wt=v*m */ for (i=0; ilierank; resmat=m; char_init(grp); Weylloopinit(g); domchar=simp_domchar(lambda,NULL,g); /* compute dominant part character */ for (i=0; inrows; i++) /* traverse all dominant weights */ { multi=domchar->coef[i]; /* this is already shared */ Weylloop(add_branch_wt,domchar->elm[i]); /* collect induced dominant weights */ } freepol(domchar); Weylloopexit(); return char_decomp(); /* compute grp-decomposition (non virtual) */ } /* branch irreducible module `lambda' to group `grp' from composite group `G' via linear map `m' */ static poly* branch_irr(lambda,m,G) entry* lambda,** m; object G; { index i,S=Ssrank(G),td=G->g.toraldim,r=Lierank(grp); poly* x; if (type_of(G)==SIMPGRP) return simp_branch_irr(lambda,m,&G->s); if (simpgroup(G)) return simp_branch_irr(lambda,m,Liecomp(G,0)); lambda+=S; m+=S; x=mkpoly(1,r); mulvecmatelm(lambda,m,*x->elm,td,r); *x->coef=one; x=Alt_dom(x); /* ensure dominant */ for (i=G->g.ncomp-1; i>=0; i--) { simpgrp* g=Liecomp(G,i); index d=g->lierank; lambda-=d; m-=d; { poly* y=simp_branch_irr(lambda,m,g),* z=Tensor(y,x); /* tensor in grp */ freepol(x); freepol(y); x=z; } } return x; } /* the following provides a direct entry point for branching irreducibles */ poly* Branch_irr(lambda,m,G) entry* lambda,** m; object G; { poly* ans; rsub=Lierank(grp); ssub=Ssrank(grp); add_wt=mkintarray(rsub); ans=branch_irr(lambda,m,G); freearr(add_wt); return ans; } /* branch module `p' to group `grp' from group `G' via linear map `m' */ poly* Branch(p,m,G) poly* p; entry** m; object G; { index i; entry** lambda=p->elm; poly* ans=poly_null(rsub=Lierank(grp)); ssub=Ssrank(grp); add_wt=mkintarray(rsub); for (i=0; inrows; i++) /* lambda= &(p->elm[i]) */ ans=Addmul_pol_pol_bin(ans,branch_irr(*lambda++,m,G),p->coef[i]); freearr(add_wt); return ans; } poly* Collect(p,iresmat,d,g) poly* p; matrix* iresmat; entry d; object g; { index i,j,r=Lierank(grp),s=Ssrank(g); poly* dc=Domchar_p(p),* result; entry** ires=iresmat->elm,** dom_ch=dc->elm,* add_wt=mkintarray(r); char_init(g); for (i=0; inrows; i++) { mulvecmatelm(*dom_ch++,ires,add_wt,r,r); /* lift to the group g */ for (j=0; jcoef[i],false); /* add to char */ nxt_i: ; } grp=g; /* decomp for containing group, while Domchar was for subgroup */ result=char_decomp(); freearr(add_wt); freepol(dc); return result; } LiE/box/centr.c0000644000175000017500000001061106760533010012523 0ustar hakanhakan#include "lie.h" #ifdef __STDC__ static simpgrp* Compontype(entry** a,index n); static void centroots(matrix* m,entry* h); #endif /* given connected component in root graph, get its type */ /* a[0:n-1] is the list of positive roots in root graph */ static simpgrp* Compontype(a,n) entry** a; index n; { simpgrp* g; index offset=0; if (type_of(grp)==SIMPGRP) g= &grp->s; else /* find relevant component of grp: */ { index l=0,r=0,i=0; entry* p= *a; while(!*p++)l++; /* l is index of first nonzero entry in first root */ do r+=Liecomp(grp,i++)->lierank; while (r<=l); g=Liecomp(grp,--i); offset=r-g->lierank; } if (n==Numproots((object)g)) return g; if (n==4) return mksimpgrp('B',2); if (n==63) return mksimpgrp('E',7); /* At this point we have handled the cases B2,E7,E8,F4 and G2 */ { char g_type=g->lietype,btype='B'; entry arank=1,brank=3, r=g->lierank; /* find rank of type A system, if any, with n roots */ { entry n_roots=1; while (n!=n_roots) if ((n_roots+= ++arank)>n) {arank=0; break;} } if (arank && (g_type=='A' || g_type=='F' || g_type=='G')) return mksimpgrp('A',arank); /* in these cases it can only be type A */ /* At this point we have also treated all cases where g_type is A or G */ { entry n_roots=9; /* for type B3/C3 */ while (n!=n_roots) { if ((n_roots+=brank)>n || ++brank>r) {brank=0; break;} if (n==n_roots) { btype='D'; break; } else n_roots+=brank; } } if (arank && !brank) return mksimpgrp('A',arank); /* type C system has no subsystem of type B (except B2): */ if (btype=='B' && g_type=='C') btype='C'; /* only for g_type='F' and n=9 is there doubt about btype: */ if (g_type=='F' && n==9) { entry i,n_short=0; entry* v; for (i=0; i<9; i++) { v= &a[i][offset]; if (v[3]==1 || v[2]-v[3]==1) n_short++; } return mksimpgrp(n_short==3 ? 'B' : 'C' ,3); } if (brank && !arank) /* then also n!=36 */ return mksimpgrp(btype,brank); /* At this point we have both arank and brank positive */ /* The type may be A[arank], btype[brank], or if n=36, E6 We recognise the A and E types by the number of roots not perpendicular to an arbitrarily chosen one. The expected number is type A[arank]: 2*arank-1 type B[brank]: 2*brank-1 (for short root) or 4*brank-7 (long root) type C[brank]: 2*brank-1 (for long root) or 4*brank-7 (short root) type D[brank]: 4*brank-7 type E[7]: 21 One checks that (apart from the B/C distinction which is already made) none of these can be equal under the additional condition arank*(arank+1)/2 = if type=B,C then brank^2 else brank*(brank-1) fi (=n), except for the irrelevant cases A1:B/C1 and A3:D3 (and A-1:D1). */ { entry* v= *a; index i,not_perp=1; /* for root v itself */ for (i=1; inrows; entry** a=ma->elm; do for (j=next; jelm,h,hh,s,r); for (i=0; inrows; i++) { value=inprow(hh,m->elm[i],s); if (h[r]) value %= h[r]; if (value==0) swap_rows(&m->elm[i],&m->elm[n_ok++]); /* no row aliases */ } m->nrows=n_ok; freearr(hh); } matrix* Centroots(mm) matrix* mm; /* matrix of toral elements */ { entry i; matrix* result=copymatrix(Posroots(grp)); for(i=0; inrows; i++) { centroots(result,mm->elm[i]); if (!result->nrows) break; } return result; } object Centrtype(h) matrix* h; { index n_comp=0,i,next; matrix* c=Centroots(h); group* ans=mkgroup(Ssrank(grp)); ans->toraldim=Lierank(grp); for (i=0; inrows; i=next) { next=isolcomp(c,i); ans->liecomp[n_comp]=Compontype(&c->elm[i],next-i); ans->toraldim -= ans->liecomp[n_comp++]->lierank; } ans->ncomp=n_comp; freemem(c); return (object)ans; } LiE/box/contragr.c0000644000175000017500000000332706760533010013235 0ustar hakanhakan#include "lie.h" #ifdef __STDC__ static void simp_contragr(entry* y,entry* x,simpgrp* g); #endif /* Find the contragredient representation of y; store in x */ static void simp_contragr(y,x,g) entry* y,* x; simpgrp* g; { register index i; index r=g->lierank; switch (g->lietype) { case 'A': for (i=0; incomp); entry* y=v->compon,* x=contr->compon; if (type_of(grp)==SIMPGRP) simp_contragr(y,x,&grp->s); else if (simpgroup(grp)) simp_contragr(y,x,Liecomp(grp,0)); else { index i,n=grp->g.ncomp,d; for (i=0; ilierank; simp_contragr(y,x,g); } for (i=0; ig.toraldim; i++) *x++= -*y++; /* negate torus part */ } return contr; } poly* Contragr_p(p,grp) poly* p; object grp; { poly* contr=mkpoly(p->nrows,p->ncols); index i; bigint** c=p->coef,** cc=contr->coef; for (i=0; inrows; i++) { entry* y=p->elm[i],* x=contr->elm[i]; setshared(*c); *cc++ = *c++; if (type_of(grp)==SIMPGRP) simp_contragr(y,x,&grp->s); else if (simpgroup(grp)) simp_contragr(y,x,Liecomp(grp,0)); else { index i,n=grp->g.ncomp,d; for (i=0; ilierank; simp_contragr(y,x,g); } for (i=0; ig.toraldim; i++) *x++= -*y++; /* negate torus part */ } } return contr; } LiE/box/defs.c0000644000175000017500000000202207075566121012337 0ustar hakanhakan/* this file allows the the user/programmer to add some builtin functions to LiE and to "dynamically" include them, without having to touch or recompile the library interface in the static[1-7].c files. Each file that contains new builtin functions should define a parameterless void initialisation function that installs the necessary functions by calling on of the macros A0-A5 defined in lie.h (their syntax is identical to C0-C5 used in the static[1-7].c files, but they expand to statements). To arrange that the initialisation function be declared and called, add its name followed by "(VID)," (without the quotes) to defs.h; the function |add_user_defined| below then ensures that all initialisation functions are called in order */ #include "lie.h" #ifdef __STDC__ #define VID void #else #define VID #endif void #include "defs.h" add_user_defined (VID); /* just to have something after the final comma */ #undef VID #define VID void add_user_defined() { #include "defs.h" (void)0; /* idem */ #undef VID } LiE/box/diagram.c0000644000175000017500000000454706760533010013027 0ustar hakanhakan#include "lie.h" object Diagram(grp) object grp; { register index i,j,k,r; index offset=0; simpgrp* gk; Printf("\n"); /* Repeat over simple components: */ for (k=0; kg.ncomp; k++,offset+=r) { gk=Liecomp(grp,k); r=gk->lierank; if(r<12) switch (gk->lietype) { case 'A': for (i=1; i<=r-1; i++) Printf("O---"); Printf("O\n"); for (i=1; i<=r; i++) Printf("%-4ld",offset+i); Printf("\n"); break; case 'B': for (i=1; i<=r-2; i++) Printf("O---"); Printf("O=>=O\n"); for (i=1; i<=r; i++) Printf("%-4ld",offset+i); Printf("\n"); break; case 'C': for (i=1; i<=r-2; i++) Printf("O---"); Printf("O=<=O\n"); for (i=1; i<=r; i++) Printf("%-4ld",offset+i); Printf("\n"); break; case 'D': for (j=0; j<3; j++) { for (i=1; i<=4*(r-3); i++) Printf(" "); if (j) Printf("|\n"); else Printf("O %ld\n",(long)(offset+r-1)); } for (i=2; i=O---O\n"); for (i=1; i<=4; i++) Printf("%-4ld",offset+i); Printf("\n"); break; case 'G': Printf(" 3\nO=<=O\n%-4ld%ld\n",(long)(offset+1),(long)(offset+2)); } else /* r>=12 */ { char t=gk->lietype; if (t=='D') for (i=0; i<3; i++) { for (j=32; --j>=0; ) Printf(" "); if (i) Printf("|\n"); else Printf("O %ld\n",(long)(offset+r-1)); } Printf("O---O---O---O-- . . . --O---O---O%sO\n" , t=='B' ? "=>=" : t=='C' ? "=<=" : "---"); for (i=1; i<=4; i++) Printf("%-4ld",offset+i); for (i=0; i<8; i++) Printf(" "); for (i=r-(t=='D'?4:3); i<=r; i++) if (t!='D' || i!=r-1) Printf("%-4ld",offset+i); Printf("\n"); } Printf("%c%ld\n\n",gk->lietype,(long)(gk->lierank)); } /* End repeat over components */ if (grp->g.toraldim) { if (grp->g.ncomp) Printf("With %ld-dimensional central torus.\n\n",(long)grp->g.toraldim); else Printf ("A %ld-dimensional torus.\n\n",(long)grp->g.toraldim); } else if (grp->g.ncomp==0) Printf("Trivial group.\n\n"); return (object)NULL; } LiE/box/matrix.c0000644000175000017500000000610306760533010012715 0ustar hakanhakan#include "lie.h" /* copy array of entry's of length n */ void copyrow(entry* from,entry* to,index n) { entry* lim=to+n; while (toncols, m->nrows); elm = m->elm; telm = t->elm; for (i=0; inrows; i++) { entry* mijptr= *elm++; for (j=0; jncols; j++) telm[j][i] = *mijptr++; } return t; } void mulmatmatelm(entry** a,entry** b,entry** c, index l, index m, index n) { register index j; index i, k; entry sum,* cikptr; register entry* aijptr; for (i = 0; incols!=b->nrows) error ("Product of incompatible matrices\n"); m = mkmatrix(a->nrows, b->ncols); mulmatmatelm(a->elm,b->elm,m->elm,a->nrows,a->ncols,b->ncols); return m; } matrix* Blockmat(a,b) matrix* a,* b; { index i=a->nrows,j,k=a->ncols,l=b->ncols; matrix* c=mkmatrix(i+b->nrows,k+l); entry** p=c->elm,** q=a->elm,* pi,* qi; while (i-->0) { pi= *p++; qi= *q++; j=k; while (j-->0) *pi++= *qi++; j=l; while (j-->0) *pi++=0; } q=b->elm; i=b->nrows; while (i-->0) { pi= *p++; qi= *q++; j=k; while (j-->0) *pi++=0; j=l; while (j-->0) *pi++= *qi++; } return c; } void printarr(a,n) entry* a; index n; { Printf("["); if (n>0) while(Printf("%ld",(long)(*a++)),--n>0) Printf(","); Printf("]"); } LiE/box/orbit.c0000644000175000017500000000077706760533010012543 0ustar hakanhakan#include "lie.h" matrix* Orbit(limit,vec,m,n) index limit,n; vector* vec; entry** m; { index i, j, l=vec->ncomp, last, cur; matrix* result = mkmatrix(limit+1,l); entry** res= result->elm; copyrow(vec->compon,res[0],l); for (cur=0,last=1; curlast) if (++last>limit) error("Orbit size exceeds given limit\n"); } result->nrows=last; return result; } LiE/box/defs.h0000664000175000017500000000000007101252426012326 0ustar hakanhakanLiE/box/static3.c0000644000175000017500000011317707120142601012766 0ustar hakanhakan/* Group operations */ #include "lie.h" static void check_wt(vector* lambda, index r) { if (lambda->ncomp!=r) error("Size of weight should equal Lie rank.\n"); } static void check_wts(matrix* m, index r) { if (m->ncols!=r) error("Size of weights should equal Lie rank.\n"); } static void check_rt(vector* rt, index s) { if (rt->ncomp!=s) error("Size of root should equal semisimple rank.\n"); } static void check_rts(matrix* m, index s) { if (m->ncols!=s) error("Size of roots should equal semisimple rank.\n"); } static void check_toral(vector* t, index r, index lim) { if (t->ncomp!=r+1) error("Size of toral element should equal Lie rank + 1.\n"); if (t->compon[r]ncols!=r+1) error("Size of toral elements should equal Lie rank + 1.\n"); for (i=0; inrows; i++) if (m->elm[i][r]<0) error("Final entry of toral elements should not be negative.\n"); } void testdom(entry* v, object grp) { index j, s=Ssrank(grp); for(j=0; jncomp; entry* w=ww->compon; for (i=0; is) error("Weyl word entries should not exceed semisimple rank.\n"); } static void check_Wws(matrix* m, index s) { index i,j,l=m->ncols; for (i=0; inrows; i++) { entry* w=m->elm[i]; for (j=0; js) error("Weyl word entries should not exceed semisimple rank.\n"); } } object int_eq_grp_grp(g1,g2) object g1,g2; /* used externally (decomp) */ { index i; if (g1->g.ncomp!=g2->g.ncomp || g1->g.toraldim!=g2->g.toraldim) return (object) bool_false; for (i=0; ig.ncomp; i++) { simpgrp* s1=Liecomp(g1,i); simpgrp* s2=Liecomp(g2,i); if (s1->lietype!=s2->lietype || s1->lierank!=s2->lierank) return (object) bool_false; } return (object) bool_true; } static object grp_mul_grp_grp(g1, g2) object g1,g2; { index i, ng1=g1->g.ncomp, ng2=g2->g.ncomp; object result = (object) mkgroup(ng1+ng2); for (i = 0; ig.toraldim = g1->g.toraldim + g2->g.toraldim; return (result); } static object grp_select_grp_int(g,n) object g,n; { object result; index i = n->i.intval; if (i<0 || i> g->g.ncomp) error("Index into group out of range.\n"); if (i>0) { result= (object) mkgroup(1); Liecomp(result,0) = Liecomp(g,i-1); return result; } result= (object) mkgroup(0); result->g.toraldim = g->g.toraldim; return result; } static object vec_sort_vec(v) object v; { vector* w=copyvector(&v->v); sortrow(w->compon,w->ncomp); return (object) w; } static object mat_sort_mat(m) matrix* m; { matrix* w=copymatrix(m); Qksortmat(w,cmpfn); return (object) w; } static object mat_unique_mat(m) matrix* m; { return (object) Unique(copymatrix(m),cmpfn); } static object mat_blockmat_mat_mat(a,b) matrix* a,* b; { return (object) Blockmat(a,b); } static object vid_setdefault_grp(g) object g; { if ((cmpfn==height_decr||cmpfn==height_incr) && defaultgrp) unmark_sorted(); defaultgrp=g; return (object) NULL; } static object vid_setdefault(void) { if (!defaultgrp) error("No default group defined yet.\n"); Printf("%5s"," "); printgrp(defaultgrp); Printf("\n"); return (object) NULL; } static object grp_setdefault(void) { if (!defaultgrp) error("No default group defined yet.\n"); return (object) defaultgrp; } static object mat_center_grp(g) object g; { return (object) Center(g); } static object int_dim_grp(object g) { return (object) mkintcel(Dimgrp(g)); } static object vid_diagram_grp(g) object g; { return Diagram(g); } static object vec_liecode_grp(g) object g; { object result; if (g->g.ncomp && !simpgroup(g)) error("No liecode for composite groups.\n"); result= (object) mkvector(2); if (g->g.ncomp == 0) { result->v.compon[0]=0; result->v.compon[1]=g->g.toraldim; } else { simpgrp* s=Liecomp(g,0); result->v.compon[0]=(s->lietype - 'A' + 1); result->v.compon[1]=s->lierank; } return result; } static object groupmake(char lietype,index rank) { object result; if (wronggroup(lietype,rank)) error("Result %c%ld is illegal group.\n", lietype, (long)rank); if (lietype=='T') { result=(object) mkgroup((index) 0); result->g.toraldim=rank; } else { result=(object) mkgroup((index) 1); Liecomp(result,0)=mksimpgrp(lietype,rank); } return result; } static object grp_liegroup_int_int(typ,rank) object typ, rank; { entry n = typ->i.intval; if (n<0 && n>7) error ("There is no group of such a type.\n"); return groupmake(n ? 'A'-1+n : 'T',rank->i.intval); } object int_ncomp_grp(g) group* g; { return (object) mkintcel(g->ncomp); } static object int_lierank_grp(g) object g; { return (object) mkintcel(Lierank(g)); } static object int_cartan_vec_vec_grp(v,w,g) vector* v,* w; object g; { index s=Ssrank(grp=g); check_rt(v,s); check_rt(w,s); checkroot(w->compon); return (object) mkintcel(Cart_inprod(v->compon,w->compon)); } static object mat_cartan_grp(object g) { grp=g; return (object) Cartan(); } static object grp_carttype_mat_grp(m,g) matrix* m; object g; { check_rts(m,Ssrank(grp=g)); return (object) Carttype(m); } static object mat_centroots_vec_grp(t,g) vector* t; object g; { index r=Lierank(grp=g); matrix* m=mkmatrix(1,r+1); check_toral(t,r,0); copyrow(t->compon,*m->elm,r+1); return (object) Centroots(m); } static object mat_centroots_mat_grp(m,g) matrix* m; object g; { check_torals(m,Lierank(grp=g)); return (object) Centroots(m); } static object grp_centrtype_vec_grp(t,g) vector* t; object g; { index r=Lierank(grp=g); matrix* m=mkmatrix(1,r+1); check_toral(t,r,0); copyrow(t->compon,*m->elm,r+1); return (object) Centrtype(m); } static object grp_centrtype_mat_grp(m,g) matrix* m; object g; { check_torals(m,Lierank(grp=g)); return (object) Centrtype(m); } object mat_closure_mat_grp(m,g) matrix* m; object g; { check_rts(m,Ssrank(grp=g)); return (object) Closure (m,true,0); } static object int_detcart_grp(object g) { grp=g; return (object) mkintcel(Detcartan()); } static object mat_domweights_vec_grp(v,g) vector* v; object g; { check_wt(v,Lierank(grp=g)); testdom(v->compon,g); return (object) Domweights(v); } object mat_fundam_mat_grp(m,g) matrix* m; object g; { check_rts(m,Ssrank(grp=g)); return (object) Closure (m,false,0); } static object vec_highroot_grp(grp) object grp; { if (grp->g.ncomp!=1) error("Only groups with one simple component have a highroot.\n"); return (object) Highroot(Liecomp(grp,0)); } static object mat_icartan_grp(object g) { grp=g; return (object) Icartan(); } static object int_inprod_vec_vec_grp(v,w,g) vector* v,* w; object g; { index s=Ssrank(grp=g); check_rt(v,s); check_rt(w,s); return (object) mkintcel(Inprod(v->compon,w->compon)); } static object int_norm_vec_grp(root,g) vector* root; object g; { check_rt(root,Ssrank(grp=g)); return (object) mkintcel(Inprod(root->compon,root->compon)); } static object int_numproots_grp(g) object g; { return (object) mkintcel(Numproots(g)); } static object mat_posroots_grp(g) object g; { return ((object) Posroots(g)); } static object mat_bhdesc_vec_grp(w,g) vector* w; object g; { vector* rw=(check_Ww(w,Ssrank(grp=g)),Reduce(w)); matrix* result=Bh_desc(rw->compon,rw->ncomp); freemem(rw); return (object) result; } static object mat_bhdesc_vec_vec_grp(v,w,g) vector* v,* w; object g; { index i,s=Ssrank(grp=g); vector* rw; entry* x=mkintarray(s); matrix* result; check_Ww(v,s); check_Ww(w,s); for (i=0; icompon,rw->ncomp,x); freearr(x); freemem(rw); return (object) result; } static object int_bhleq_vec_vec_grp(v,w,g) vector* v,* w; object g; { index s=Ssrank(grp=g); check_Ww(v,s); check_Ww(w,s); return (object) (Bh_leq(v,w) ? bool_true : bool_false); } static object vec_canonical_vec_grp(v,g) vector* v; object g; { check_Ww(v,Ssrank(grp=g)); return (object) Canonical(v); } static object mat_canonical_mat_grp(m,g) matrix* m; object g; { check_Wws(m,Ssrank(grp=g)); return (object) Canonicals(m); } static object vec_dominant_vec_grp(v,g) vector* v; object g; { check_wt(v,Lierank(grp=g)); return (object) Dominant(v); } static object mat_dominant_mat_grp(m,g) matrix* m; object g; { index i; matrix* result=(check_wts(m,Lierank(grp=g)),copymatrix(m)); for (i=0; inrows; i++) make_dominant(result->elm[i]); return (object) result; } static object pol_dominant_pol_grp(p,g) poly* p; object g; { index i; poly* result=(check_pol(p,Lierank(grp=g)),copypoly(p)); for (i=0; inrows; i++) make_dominant(result->elm[i]); return (object) Reduce_pol(result); } static object vec_exponents_grp(g) object g; {return ((object) Exponents(g));} static object mat_filterdom_mat (m,g) matrix* m; object g; { check_wts(m,Lierank(grp=g)); return (object) Filter_dom_m(m); } static object pol_filterdom_pol (p,g) poly* p; object g; { check_pol(p,Lierank(grp=g)); return (object) Filter_dom(p); } static object pol_klpoly_vec_vec_grp(x,y,g) vector* x,* y; object g; { index s=Ssrank(grp=g); poly* result; cmpfn_tp sav_cmp=cmpfn; check_Ww(x,s); check_Ww(y,s); cmpfn=lex_decr; result=KLpoly(x,y); cmpfn=sav_cmp; if (cmpfn!=lex_decr) clrsorted(result); return (object) result; } static object int_length_vec_grp(v,g) vector* v; object g; { check_Ww(v,Ssrank(grp=g)); return (object) mkintcel(Length(v)); } object vec_longword_grp(g) object g; { index i,s=Ssrank(grp=g); entry* minus_rho=mkintarray(s); vector* result; for (i=0; incomp; entry* w=mkintarray(l); check_Ww(ww,Ssrank(grp=g)); copyrow(ww->compon,w,l); result=L_red(L,w,l); freearr(w); return (object) result; } static object vec_lrreduce_vec_vec_vec_grp(L,ww,R,g) vector* L,* ww,* R; object g; { vector* result; index l=ww->ncomp; entry* w=mkintarray(l); check_Ww(ww,Ssrank(grp=g)); copyrow(ww->compon,w,l); result=LR_red(L,w,l,R); freearr(w); return (object) result; } static object mat_orbit_int_vec_mat(i,v,m) intcel* i; vector* v; matrix* m; { if (v->ncomp != m->ncols) error ("Size of vector should match number of columns of matrix"); if (!v->ncomp) return (object) mkmatrix(1,0); /* one empty vector */ if (m->nrows % v->ncomp) error ("Size of vector should divide number of rows of matrix"); if (i->intval<1) error ("limit for orbit must be positive"); return (object) Orbit(i->intval,v,m->elm,m->nrows/v->ncomp); } static object mat_orbit_vec_mat(v,m) vector* v; matrix* m; { if (v->ncomp != m->ncols) error ("Size of vector should match number of columns of matrix"); if (!v->ncomp) return (object) mkmatrix(1,0); /* one empty vector */ if (m->nrows % v->ncomp) error ("Size of vector should divide number of rows of matrix"); return (object) Orbit(1000,v,m->elm,m->nrows/v->ncomp); } static object vec_reduce_vec_grp(ww,g) vector* ww; object g; { vector* empty=mkvector(0); object result=vec_lreduce_vec_vec_grp(empty,ww,g); freemem(empty); return result; } static object mat_reflection_vec_grp(rt,g) vector* rt; object g; { check_rt(rt,Ssrank(grp=g)); checkroot(rt->compon); return (object) Reflection(rt->compon); } static object vec_rreduce_vec_vec_grp(ww,R,g) vector* ww,* R; object g; { vector* result; index i,l=ww->ncomp; entry* w=mkintarray(l); check_Ww(ww,Ssrank(grp=g)); for (i=0; icompon[l-1-i]; result=L_red(R,w,l); freearr(w); { index n=result->ncomp-1; entry* res=result->compon; /* reverse */ for (i=0; icompon,word); return (object) result; } static object mat_waction_vec_grp(word,g) vector* word; object g; { check_Ww(word,Ssrank(grp=g)); return (object) Weyl_mat(word); } static object mat_waction_mat_vec_grp(matrix* m, vector* word, object g) { index i; matrix* result; check_wts(m,Lierank(grp=g)); check_Ww(word,Ssrank(g)); result=copymatrix(m); for (i=0; inrows; ++i) Waction(result->elm[i],word); return (object) result; } static object pol_waction_pol_vec_grp(poly* p, vector* word, object g) { index i; poly* result; check_pol(p,Lierank(grp=g)); check_Ww(word,Ssrank(g)); result=copypoly(p); for (i=0; inrows; ++i) Waction(result->elm[i],word); return (object) result; } static object mat_worbit_vec_grp(vector* v, object g) { check_wt(v,Lierank(grp=g)); return (object) Weyl_orbit(v->compon,NULL); } static object mat_worbitgraph_vec_grp(vector* v, object g) { matrix* r,* orbit_graph; check_wt(v,Lierank(grp=g)); r=Weyl_orbit(v->compon,&orbit_graph); freemem(r); return (object) orbit_graph; } static object pol_worbit_pol_grp(p,g) poly* p; object g; { check_pol(p,Lierank(grp=g)); return (object) Worbit_p(p); } static object bin_worbitsize_vec_grp(v,g) vector* v; object g; { check_wt(v,Lierank(grp=g)); return (object) Orbitsize(v->compon); } static object bin_worder_grp(g) object g; { return (object) Worder(grp=g); } static object bin_worder_vec_grp(I,g) object I,g; { index i,s=Ssrank(grp=g); for(i=0; iv.ncomp; i++) if (I->v.compon[i]>s || I->v.compon[i]<=0) { Printf("Reflection %ld",(long)I->v.compon[i]); error(" is out of range.\n"); } return (object) sub_Worder(&I->v); } static object vec_wrtaction_vec_vec_grp(v,word,g) vector* v,* word; object g; { index s=Ssrank(grp=g); vector* result; check_rt(v,s); check_Ww(word,s); result=copyvector(v); Wrtaction(result->compon,word); return (object) result; } static object mat_wrtaction_vec_grp(word,g) vector* word; object g; { check_Ww(word,Ssrank(grp=g)); return (object) Weyl_rt_mat(word); } static object mat_wrtaction_mat_vec_grp(matrix* m, vector* word, object g) { index i; matrix* result; check_wts(m,Lierank(grp=g)); check_Ww(word,Ssrank(g)); result=copymatrix(m); for (i=0; inrows; ++i) Wrtaction(result->elm[i],word); return (object) result; } static object mat_wrtorbit_vec_grp(v,g) vector* v; object g; { check_rt(v,Ssrank(grp=g)); return (object) Weyl_root_orbit(v->compon); } static object vec_wword_vec_grp(w,g) vector* w; object g; { check_wt(w,Lierank(grp=g)); return (object) Wwordv(w->compon,-1); } object vec_wword_mat_grp(m,g) matrix* m; object g; { if (m->nrows != m->ncols || m->nrows != Lierank(grp=g)) error("Matrix should be square, of size Lie rank.\n"); return (object) Wwordm(m); } static object bin_classord_vec(lambda) vector* lambda; { index l=lambda->ncomp; check_part(lambda->compon,l); return (object) Classord(lambda->compon,l); } static object vec_frompart_vec(lambda) vector* lambda; { if (lambda->ncomp==0) error("Partition should not be empty.\n"); return (object) From_Part_v(lambda->compon,lambda->ncomp); } static object mat_frompart_mat(m) matrix* m; { if (m->ncols==0) error("Partitions should not be empty.\n"); return (object) From_Part_m(m->elm,m->nrows,m->ncols); } static object pol_frompart_pol(p) poly* p; { if (p->ncols==0) error("Partitions should not be empty.\n"); return (object) From_Part_p(p); } static object vec_nextpart_vec(v) vector* v; { index l=v->ncomp; vector* result; if (check_part(v->compon,l)==0) return (object) v; while (l>0 && v->compon[l-1]==0) l--; result=mkvector(l+1); copyrow(v->compon,result->compon,l); result->compon[l]=0; Nextpart (result->compon,l); while (result->compon[l]==0) l--; result->ncomp=l+1; return (object) result; } static object vec_nextperm_vec(v) vector* v; { index n=v->ncomp; vector* result; result=mkvector(n); copyrow(v->compon,result->compon,n); Nextperm(result->compon,n); return (object) result; } object vec_nexttab_vec(t) vector* t; { index l=t->ncomp; vector* result; entry* res; result=check_tabl(t); /* perform tests */ freemem(result); result=mkvector(l); res=result->compon; copyrow(t->compon,res,l); Nexttableau(res,l); return (object) result; } object bin_ntabl_vec(lambda) vector* lambda; { index l=lambda->ncomp; check_part(lambda->compon,l); return (object) n_tableaux(lambda->compon,l); } static object mat_partitions_int(p) intcel* p; { index n=p->intval; if(n<0) error("Partitions should be taken of non-negative numbers only.\n"); return (object) Partitions(n); } static object vid_prtab_vec(v) vector* v; { vector* s; entry* square=v->compon; index n= v->ncomp, i,r, d=2, m=10; while(n>=m) {d++; m*=10;} /* d=number of positions needed per entry */ s=check_tabl(v); m=s->ncomp; freemem(s); for (r=1; r<=m; r++) { for (i=0; incomp; entry* p,* q; vector* w; if (n!=Q->ncomp) error("Tableaux not of same size"); { index i; vector* sp=check_tabl(P),* sq=check_tabl(Q); boolean ok=(sp->ncomp==sq->ncomp); if (ok) for(i=0;incomp;i++) if(sp->compon[i]!=sq->compon[i]) ok=0; freemem(sp); freemem(sq); if(!ok) error("Tableaux not of same shape\n"); } if (isshared(P)) { p=mkintarray(n); copyrow(P->compon,p,n); } else p=P->compon; if (isshared(Q)) { q=mkintarray(n); copyrow(Q->compon,q,n); } else q=Q->compon; w=mkvector(n); Robinson_Schensted(p,q,n,w->compon); if (p!=P->compon) freearr(p); if (q!=Q->compon) freearr(q); return (object) w; } static object mat_RS_vec(W) vector* W; { index i,n=W->ncomp; entry* w=W->compon; matrix* pq; for(i=0; in) error("No permutation: entry out of range.\n"); pq=mkmatrix(2,n); Schensted_Robinson(w,n,pq->elm[0],pq->elm[1]); return (object) pq; } static object int_signpart_vec(v) vector* v; { entry* lambda=v->compon; index l=v->ncomp; check_part(lambda,l); return (object) mkintcel(Sign_part(lambda,l)); } static object vec_shape_vec(v) vector* v; { return (object) check_tabl(v); } static object bin_symchar_vec_vec(vector* a,vector* b) { entry* lambda=a->compon,* mu=b->compon; index l=a->ncomp,m=b->ncomp,n=check_part(lambda,l); if (n!=check_part(mu,m)) error ("Partitions should be of the same number.\n"); return (object) MN_char_val(lambda,mu,l,m); } static object poly_symchar_vec(a) vector* a; { return (object) MN_char(a->compon,a->ncomp); } static object mat_symorbit_vec(v) vector* v; { return (object) Permutations(v->compon,v->ncomp); } static object mat_tableaux_vec(lambda) vector* lambda; { return (object) Tableaux(lambda->compon,lambda->ncomp);} static object vec_topart_vec(v) vector* v; { return (object) To_Part_v(v->compon,v->ncomp); } static object mat_topart_mat(m) matrix* m; { return (object) To_Part_m(m->elm,m->nrows,m->ncols); } static object pol_topart_pol(p) poly* p; { return (object) To_Part_p(p); } static object vec_transpart_vec(v) vector* v; { entry* lambda=v->compon; index l=v->ncomp; check_part(lambda,l); return (object) Trans_part(lambda,l); } static object pol_adams_int_vec_grp(d,v,g) intcel* d; vector* v; object g; { index r=Lierank(grp=g),n=d->intval; if (n<=0) error("Scalar factor in Adams should be positive.\n"); check_wt(v,r); return (object) Adams(n,Pol_from_vec(v)); } static object pol_adams_int_pol_grp(d,p,g) intcel* d; poly* p; object g; { index r=Lierank(grp=g),n=d->intval; if (n<=0) error("Scalar factor in Adams should be positive.\n"); check_pol(p,r); return (object) Adams(n,p); } static object pol_adjoint_grp(g) object g; { grp=g; return (object) Adjoint(grp); } static object pol_altdom_pol_grp(p,g) poly* p; object g; { check_pol(p,Lierank(grp=g)); return (object) Alt_dom(p); } static object pol_altdom_vec_grp(v,g) vector* v; object g; { check_wt(v,Lierank(grp=g)); return (object) Alt_dom(Pol_from_vec(v)); } static object pol_altdom_pol_vec_grp(p,w,g) poly* p; vector* w; object g; { check_Ww(w,Ssrank(grp=g)); check_pol(p,Lierank(g)); return (object) Alt_dom_w(p,w); } static object pol_altdom_vec_vec_grp(v,w,g) vector* v,* w; object g; { check_Ww(w,Ssrank(grp=g)); check_wt(v,Lierank(g)); return (object) Alt_dom_w(Pol_from_vec(v),w); } static object pol_alttensor_int_pol_grp(d,p,g) object d,g; poly* p; { index r=Lierank(grp=g),n=d->i.intval; if (n<0) error("Cannot take negative tensor power.\n"); p=check_pol(p,r); return (object) SAtensor(true,n,p); } static object pol_alttensor_int_vec_grp(d,v,g) object d,g; vector* v; { index r=Lierank(grp=g),n=d->i.intval; if (n<0) error("Cannot take negative tensor power.\n"); check_wt(v,r); return (object) SAtensor(true,n,Pol_from_vec(v)); } static object pol_altwsum_pol_grp(p,g) poly* p; object g; { check_pol(p,Lierank(grp=g)); return (object) alt_Wsum(p); } static object pol_altwsum_vec_grp(v,g) vector* v; object g; { check_wt(v,Lierank(grp=g)); return (object) alt_Wsum(Pol_from_vec(v)); } static object pol_branch_vec_grp_mat_grp(v,h,m,g) vector *v; object h,m,g; { index R=Lierank(g),r=Lierank(grp=h); entry* lambda=v->compon; check_wt(v,R); if (m->m.nrows!=R) error ("Number of rows of restriction matrix should match Lie rank.\n"); if (m->m.ncols!=r) error ( "Number of columns of restriction matrix should match rank subgroup.\n"); testdom(lambda,g); return (object) Branch_irr(lambda,m->m.elm,g); } static object pol_branch_pol_grp_mat_grp(p,h,m,g) poly *p; object h,m,g; { index R=Lierank(g),r=Lierank(grp=h); p=check_pol(p,R); if (m->m.nrows!=R) error ("Number of rows of restriction matrix should match Lie rank.\n"); if (m->m.ncols!=r) error ("Number of columns of restriction matrix\ should match rank subgroup.\n"); { index i; for (i=0; inrows; i++) testdom(p->elm[i],g);} return (object) Branch(p,m->m.elm,g); } object pol_collect_pol_grp_mat_grp(p,h,m,g) poly* p; matrix* m; object h,g; { index i,r=Lierank(grp=h),R=Lierank(g); check_pol(p,r); for(i=0;inrows;i++) testdom(p->elm[i],h); if (m->nrows!=r) error ("Number of rows of inverse restriction matrix\ should match rank subgroup.\n"); if (m->ncols!=R) error ("Number of columns of inverse restriction matrix\ should match Lie rank.\n"); return (object) Collect(p,m,1,g); } object pol_collect_pol_grp_mat_int_grp(p,h,m,n,g) poly* p; matrix* m; intcel* n; object h,g; { index i,r=Lierank(grp=h),R=Lierank(g); entry d=n->intval; check_pol(p,r); for(i=0;inrows;i++) testdom(p->elm[i],h); if (m->nrows!=r) error ("Number of rows of inverse restriction matrix\ should match rank subgroup.\n"); if (m->ncols!=R) error ("Number of columns of inverse restriction matrix\ should match Lie rank.\n"); if (d<=0) error("Denominator in collect should be positive.\n"); return (object) Collect(p,m,d,g); } static object vec_contragr_vec_grp(v,g) vector* v; object g; { check_wt(v,Lierank(grp=g)); return (object) Contragr(v,grp); } static object pol_contragr_pol_grp(p,g) poly* p; object g; { check_pol(p,Lierank(grp=g)); return (object) Contragr_p(p,grp); } static object pol_decomp_pol_grp(p,g) poly* p; object g; { index i,r=Lierank(grp=g); check_pol(p,r); for(i=0; inrows; i++) testdom(p->elm[i],g); return (object) Decomp(p); } static object pol_Demazure_pol_vec_grp(p,w,g) poly* p; vector* w; object g; { check_pol(p,Lierank(grp=g)); check_Ww(w,Ssrank(g)); return (object) Demazure(p,w); } static object pol_Demazure_vec_vec_grp(v,w,g) vector* v,* w; object g; { check_wt(v,Lierank(grp=g)); check_Ww(w,Ssrank(g)); return (object) Demazure(Pol_from_vec(v),w); } static object pol_Demazure_pol_grp(p,g) poly* p; object g; { index i,s=Ssrank(grp=g); entry* minus_rho=mkintarray(s); vector* w; poly*result; check_pol(p,Lierank(grp=g)); for (i=0; icompon); freemem(t); return (object) result; } static object bin_dim_pol_grp(p,g) poly* p; object g; { check_pol(p,Lierank(grp=g)); return (object) Dim(p); } static object pol_domchar_vec_grp(v,g) vector* v; object g; { check_wt(v,Lierank(grp=g)); testdom(v->compon,g); return (object) Domchar_irr(v->compon,NULL); } static object pol_domchar_pol_grp(p,g) poly* p; object g; { check_pol(p,Lierank(grp=g)); return (object) Domchar_p(p); /* Domchar_p does testdom itself */ } static object bin_domchar_vec_vec_grp(lambda,w,g) vector* lambda,* w; object g; { index r=Lierank(grp=g); entry* mu=mkintarray(r); copyrow(w->compon,mu,r); check_wt(lambda,r); check_wt(w,r); testdom(lambda->compon,g); make_dominant(mu); { poly* t=Domchar_irr(lambda->compon,mu); bigint* result=t->coef[0]; freearr(mu); freemem(t); return (object) result; } } static object bin_domchar_pol_vec_grp(p,w,g) poly* p; vector* w; object g; { index i,r=Lierank(grp=g); entry* mu=mkintarray(r); bigint* result=null; check_pol(p,r); check_wt(w,r); copyrow(w->compon,mu,r); make_dominant(mu); for (i=0; inrows; i++) { poly* t=(testdom(p->elm[i],g),Domchar_irr(p->elm[i],mu)); result=add(result,mult(p->coef[i],t->coef[0])); freemem(t); } freearr(mu); return (object) result; } static object pol_lrtensor_vec_vec(lambda,mu) vector* lambda,* mu; { index l=lambda->ncomp; if (l!=mu->ncomp) error ("partitions for LR_tensor should have same number of parts.\n"); check_part(lambda->compon,l); check_part(mu->compon,l); return (object) LR_tensor_irr(lambda->compon,mu->compon,l); } static object pol_lrtensor_pol_pol(p,q) poly* p,* q; { index i,l=p->ncols; if (l!=q->ncols) error ("exponents for LR_tensor should have same number of parts.\n"); for (i=0; inrows; i++) check_part(p->elm[i],l); for (i=0; inrows; i++) check_part(q->elm[i],l); return (object) LR_tensor(p,q); } static object pol_plethysm_vec_pol_grp(vector* lambda, poly* p, object g) { index n=check_part(lambda->compon,lambda->ncomp); check_pol(p,Lierank(grp=g)); return (object) Plethysm(lambda->compon,lambda->ncomp,n,p); } static object pol_plethysm_vec_vec_grp(vector* lambda,vector* mu,object g) { index n=check_part(lambda->compon,lambda->ncomp); check_wt(mu,Lierank(grp=g)); return (object) Plethysm(lambda->compon,lambda->ncomp,n,Pol_from_vec(mu)); } static object pol_ptensor_int_pol_grp(d,p,g) object d,g; poly* p; { index r=Lierank(grp=g),n=d->i.intval; if (n<0) error("Cannot take negative tensor power.\n"); p=check_pol(p,r); return (object) Ptensor(n,p); } static object pol_ptensor_int_vec_grp(d,v,g) object d,g; vector* v; { index r=Lierank(grp=g),n=d->i.intval; if (n<0) error("Cannot take negative tensor power.\n"); check_wt(v,r); return (object) Ptensor(n,Pol_from_vec(v)); } object mat_resmat_mat_grp(m,g) matrix* m; object g; { check_rts(m,Ssrank(grp=g)); return (object) Resmat(m); } static object pol_spectrum_vec_vec_grp (wt,t,g) vector* wt,* t; object g; { index r=Lierank(grp=g); check_wt(wt,r); check_toral(t,r,1); return (object) Spectrum(Pol_from_vec(wt),t); } static object pol_spectrum_pol_vec_grp (p,t,g) poly* p; vector* t; object g; { index r=Lierank(grp=g); check_pol(p,r); check_toral(t,r,1); return (object) Spectrum(p,t); } static object pol_symtensor_int_pol_grp(d,p,g) object d,g; poly* p; { index r=Lierank(grp=g),n=d->i.intval; if (n<0) error("Cannot take negative tensor power.\n"); p=check_pol(p,r); return (object) SAtensor(false,n,p); } static object pol_symtensor_int_vec_grp(d,v,g) object d,g; vector* v; { index r=Lierank(grp=g),n=d->i.intval; if (n<0) error("Cannot take negative tensor power.\n"); check_wt(v,r); return (object) SAtensor(false,n,Pol_from_vec(v)); } static object pol_tensor_pol_pol_grp(p,q,g) poly* p,* q; object g; { entry r=Lierank(grp=g); p=check_pol(p,r); q=check_pol(q,r); return (object) Tensor(p,q); } static object pol_tensor_vec_vec_grp(x,y,g) vector* x,* y; object g; { entry r=Lierank(grp=g); check_wt(x,r); check_wt(y,r); return (object) Tensor(Pol_from_vec(x),Pol_from_vec(y)); } static object bin_tensor_pol_pol_vec_grp(p,q,nu,g) poly* p,* q; vector* nu; object g; { entry r=Lierank(grp=g); p=check_pol(p,r); q=check_pol(q,r); check_wt(nu,r); return (object) Tensor_coef(p,q,nu); } static object bin_tensor_vec_vec_vec_grp(x,y,z,g) vector* x,* y,* z; object g; { entry r=Lierank(grp=g); check_wt(x,r); check_wt(y,r); check_wt(z,r); return (object) Tensor_coef(Pol_from_vec(x),Pol_from_vec(y),z); } static object pol_vdecomp_pol_grp(p,g) poly* p; object g; { index i,r=Lierank(grp=g); check_pol(p,r); for(i=0; inrows; i++) testdom(p->elm[i],g); return (object) Vdecomp(p); } static object pol_vdecomp_vec_grp(v,g) vector* v; object g; { poly* p=Pol_from_vec(v),* result; check_wt(v,Lierank(grp=g)); testdom(v->compon,g); result=Vdecomp(p); freepol(p); return (object) result; } /* The interfaces of the above defined operations. */ Symbrec static3[] = { C2("==", int_eq_grp_grp, INTEGER, GROUP, GROUP) C2("*", grp_mul_grp_grp, GROUP, GROUP, GROUP) C2("_select", grp_select_grp_int, GROUP, GROUP, INTEGER) C1("sort",vec_sort_vec,VECTOR,VECTOR) C1("sort",mat_sort_mat,MATRIX,MATRIX) C1("unique",mat_unique_mat,MATRIX,MATRIX) C2("block_mat", mat_blockmat_mat_mat,MATRIX, MATRIX, MATRIX) C1("_setdefault", vid_setdefault_grp, VOID, GRPDFT) C0("_setdefault", vid_setdefault, VOID) C0("_gsetdefault", grp_setdefault, GROUP) C1("center",mat_center_grp,MATRIX,GRPDFT) C1("diagram", vid_diagram_grp, VOID, GRPDFT) C1("dim", int_dim_grp, INTEGER, GRPDFT) C1("Lie_code", vec_liecode_grp, VECTOR, GRPDFT) C2("Lie_group", grp_liegroup_int_int, GROUP, INTEGER, INTEGER) C1("Lie_rank", int_lierank_grp, INTEGER, GRPDFT) C1("n_comp",int_ncomp_grp, INTEGER, GRPDFT) C3("Cartan", int_cartan_vec_vec_grp, INTEGER, VECTOR, VECTOR, GRPDFT) C1("Cartan", mat_cartan_grp, MATRIX, GRPDFT) C2("Cartan_type", grp_carttype_mat_grp, GROUP, MATRIX, GRPDFT) C2("cent_roots", mat_centroots_vec_grp, MATRIX, VECTOR, GRPDFT) C2("cent_roots", mat_centroots_mat_grp, MATRIX, MATRIX, GRPDFT) C2("centr_type", grp_centrtype_vec_grp, GROUP, VECTOR, GRPDFT) C2("centr_type", grp_centrtype_mat_grp, GROUP, MATRIX, GRPDFT) C2("closure", mat_closure_mat_grp, MATRIX, MATRIX, GRPDFT) C1("det_Cartan", int_detcart_grp, INTEGER, GRPDFT) C2("dom_weights", mat_domweights_vec_grp, MATRIX, VECTOR, GRPDFT) C2("fundam", mat_fundam_mat_grp, MATRIX, MATRIX, GRPDFT) C1("high_root", vec_highroot_grp, VECTOR, GRPDFT) C1("i_Cartan", mat_icartan_grp, MATRIX, GRPDFT) C3("inprod", int_inprod_vec_vec_grp, INTEGER, VECTOR, VECTOR, GRPDFT) C2("norm", int_norm_vec_grp, INTEGER, VECTOR, GRPDFT) C1("n_pos_roots", int_numproots_grp, INTEGER, GRPDFT) C1("pos_roots", mat_posroots_grp, MATRIX, GRPDFT) C2("Bruhat_desc", mat_bhdesc_vec_grp, MATRIX, VECTOR, GRPDFT) C3("Bruhat_desc", mat_bhdesc_vec_vec_grp, MATRIX, VECTOR, VECTOR, GRPDFT) C3("Bruhat_leq", int_bhleq_vec_vec_grp, INTEGER, VECTOR, VECTOR, GRPDFT) C2("canonical", vec_canonical_vec_grp, VECTOR, VECTOR, GRPDFT) C2("canonical", mat_canonical_mat_grp, MATRIX, MATRIX, GRPDFT) C2("dominant", vec_dominant_vec_grp, VECTOR, VECTOR, GRPDFT) C2("dominant", mat_dominant_mat_grp, MATRIX, MATRIX, GRPDFT) C2("dominant", pol_dominant_pol_grp, POLY, POLY, GRPDFT) C1("exponents", vec_exponents_grp, VECTOR, GRPDFT) C2("filter_dom", mat_filterdom_mat, MATRIX, MATRIX, GRPDFT) C2("filter_dom", pol_filterdom_pol, POLY, POLY, GRPDFT) C3("KL_poly", pol_klpoly_vec_vec_grp, POLY, VECTOR, VECTOR, GRPDFT) C2("length", int_length_vec_grp, INTEGER, VECTOR, GRPDFT) C1("long_word",vec_longword_grp,VECTOR,GRPDFT) C3("l_reduce", vec_lreduce_vec_vec_grp, VECTOR, VECTOR, VECTOR, GRPDFT) C4("lr_reduce", vec_lrreduce_vec_vec_vec_grp,VECTOR,VECTOR,VECTOR,VECTOR,GRPDFT) C3("orbit", mat_orbit_int_vec_mat, MATRIX, INTEGER,VECTOR,MATRIX) C2("orbit", mat_orbit_vec_mat, MATRIX, VECTOR,MATRIX) C2("reduce", vec_reduce_vec_grp, VECTOR, VECTOR, GRPDFT) C2("reflection", mat_reflection_vec_grp, MATRIX, VECTOR, GRPDFT) C3("r_reduce", vec_rreduce_vec_vec_grp, VECTOR, VECTOR, VECTOR, GRPDFT) C3("R_poly", pol_rpoly_vec_vec_grp, POLY, VECTOR, VECTOR, GRPDFT) C3("W_action", vec_waction_vec_vec_grp, VECTOR, VECTOR, VECTOR, GRPDFT) C2("W_action", mat_waction_vec_grp, MATRIX, VECTOR, GRPDFT) C3("W_action", mat_waction_mat_vec_grp, MATRIX, MATRIX, VECTOR, GRPDFT) C3("W_action", pol_waction_pol_vec_grp, POLY, POLY, VECTOR, GRPDFT) C2("W_orbit", mat_worbit_vec_grp, MATRIX, VECTOR, GRPDFT) C2("W_orbit_graph", mat_worbitgraph_vec_grp, MATRIX, VECTOR, GRPDFT) C2("W_orbit", pol_worbit_pol_grp, POLY, POLY, GRPDFT) C2("W_orbit_size", bin_worbitsize_vec_grp, BIGINT, VECTOR, GRPDFT) C1("W_order", bin_worder_grp, BIGINT, GRPDFT) C2("W_order", bin_worder_vec_grp, BIGINT, VECTOR, GRPDFT) C3("W_rt_action", vec_wrtaction_vec_vec_grp, VECTOR, VECTOR, VECTOR, GRPDFT) C2("W_rt_action", mat_wrtaction_vec_grp, MATRIX, VECTOR, GRPDFT) C3("W_rt_action", mat_wrtaction_mat_vec_grp, MATRIX, MATRIX, VECTOR, GRPDFT) C2("W_rt_orbit", mat_wrtorbit_vec_grp, MATRIX, VECTOR, GRPDFT) C2("W_word", vec_wword_vec_grp, VECTOR, VECTOR, GRPDFT) C2("W_word", vec_wword_mat_grp, VECTOR, MATRIX, GRPDFT) C1("class_ord",bin_classord_vec,BIGINT,VECTOR) C1("from_part",vec_frompart_vec,VECTOR,VECTOR) C1("from_part",mat_frompart_mat,MATRIX,MATRIX) C1("from_part",pol_frompart_pol,POLY,POLY) C1("next_part",vec_nextpart_vec,VECTOR,VECTOR) C1("next_perm",vec_nextperm_vec,VECTOR,VECTOR) C1("next_tabl",vec_nexttab_vec,VECTOR,VECTOR) C1("n_tabl",bin_ntabl_vec,BIGINT,VECTOR) C1("partitions",mat_partitions_int,MATRIX,INTEGER) C1("print_tab",vid_prtab_vec,VOID,VECTOR) C1("RS",mat_RS_vec,MATRIX,VECTOR) C2("RS",vec_RS_vec_vec,VECTOR,VECTOR,VECTOR) C1("sign_part",int_signpart_vec,INTEGER,VECTOR) C1("shape",vec_shape_vec,VECTOR,VECTOR) C2("sym_char",bin_symchar_vec_vec,BIGINT,VECTOR,VECTOR) C1("sym_char",poly_symchar_vec,POLY,VECTOR) C1("sym_orbit",mat_symorbit_vec,MATRIX,VECTOR) C1("tableaux",mat_tableaux_vec,MATRIX,VECTOR) C1("to_part",vec_topart_vec,VECTOR,VECTOR) C1("to_part",mat_topart_mat,MATRIX,MATRIX) C1("to_part",pol_topart_pol,POLY,POLY) C1("trans_part",vec_transpart_vec,VECTOR,VECTOR) C3("Adams", pol_adams_int_vec_grp, POLY,INTEGER, VECTOR, GRPDFT) C3("Adams", pol_adams_int_pol_grp, POLY,INTEGER, POLY, GRPDFT) C1("adjoint", pol_adjoint_grp, POLY, GRPDFT) C2("alt_dom", pol_altdom_pol_grp, POLY, POLY, GRPDFT) C2("alt_dom", pol_altdom_vec_grp, POLY, VECTOR, GRPDFT) C3("alt_dom", pol_altdom_pol_vec_grp, POLY, POLY, VECTOR, GRPDFT) C3("alt_dom", pol_altdom_vec_vec_grp, POLY, VECTOR, VECTOR, GRPDFT) C3("alt_tensor", pol_alttensor_int_vec_grp, POLY, INTEGER, VECTOR, GRPDFT) C3("alt_tensor", pol_alttensor_int_pol_grp, POLY, INTEGER, POLY, GRPDFT) C2("alt_W_sum", pol_altwsum_pol_grp, POLY, POLY, GRPDFT) C2("alt_W_sum", pol_altwsum_vec_grp, POLY, VECTOR, GRPDFT) C4("branch",pol_branch_vec_grp_mat_grp,POLY,VECTOR,GROUP,MATRIX,GRPDFT) C4("branch",pol_branch_pol_grp_mat_grp,POLY,POLY,GROUP,MATRIX,GRPDFT) C4("collect", pol_collect_pol_grp_mat_grp,POLY,POLY,GROUP,MATRIX,GRPDFT) C5("collect", pol_collect_pol_grp_mat_int_grp,POLY,POLY,GROUP,MATRIX,INTEGER,GRPDFT) C2("contragr", vec_contragr_vec_grp, VECTOR, VECTOR, GRPDFT) C2("contragr", pol_contragr_pol_grp, POLY, POLY, GRPDFT) C2("decomp", pol_decomp_pol_grp, POLY, POLY, GRPDFT) C3("Demazure", pol_Demazure_pol_vec_grp, POLY, POLY, VECTOR, GRPDFT) C3("Demazure", pol_Demazure_vec_vec_grp, POLY, VECTOR, VECTOR, GRPDFT) C2("Demazure", pol_Demazure_pol_grp, POLY, POLY, GRPDFT) C2("Demazure", pol_Demazure_vec_grp, POLY, VECTOR, GRPDFT) C2("dim", bin_dim_vec_grp, BIGINT, VECTOR, GRPDFT) C2("dim", bin_dim_pol_grp, BIGINT, POLY, GRPDFT) C3("dom_char", bin_domchar_vec_vec_grp, BIGINT, VECTOR, VECTOR, GRPDFT) C3("dom_char", bin_domchar_pol_vec_grp, BIGINT, POLY, VECTOR, GRPDFT) C2("dom_char", pol_domchar_vec_grp, POLY, VECTOR, GRPDFT) C2("dom_char", pol_domchar_pol_grp, POLY, POLY, GRPDFT) C2("LR_tensor",pol_lrtensor_vec_vec,POLY,VECTOR,VECTOR) C2("LR_tensor",pol_lrtensor_pol_pol,POLY,POLY,POLY) C3("plethysm", pol_plethysm_vec_vec_grp, POLY,VECTOR, VECTOR, GRPDFT) C3("plethysm", pol_plethysm_vec_pol_grp, POLY,VECTOR, POLY, GRPDFT) C3("p_tensor", pol_ptensor_int_vec_grp, POLY,INTEGER, VECTOR, GRPDFT) C3("p_tensor", pol_ptensor_int_pol_grp, POLY,INTEGER, POLY, GRPDFT) C2("res_mat", mat_resmat_mat_grp, MATRIX, MATRIX, GRPDFT) C3("spectrum", pol_spectrum_vec_vec_grp, POLY, VECTOR, VECTOR, GRPDFT) C3("spectrum", pol_spectrum_pol_vec_grp, POLY, POLY, VECTOR, GRPDFT) C3("sym_tensor", pol_symtensor_int_vec_grp, POLY, INTEGER, VECTOR, GRPDFT) C3("sym_tensor", pol_symtensor_int_pol_grp, POLY, INTEGER, POLY, GRPDFT) C3("tensor", pol_tensor_vec_vec_grp, POLY, VECTOR, VECTOR, GRPDFT) C3("tensor", pol_tensor_pol_pol_grp, POLY, POLY, POLY, GRPDFT) C4("tensor", bin_tensor_vec_vec_vec_grp, BIGINT, VECTOR, VECTOR, VECTOR, GRPDFT) C4("tensor", bin_tensor_pol_pol_vec_grp, BIGINT, POLY, POLY, VECTOR, GRPDFT) C2("v_decomp", pol_vdecomp_pol_grp, POLY, POLY, GRPDFT) C2("v_decomp", pol_vdecomp_vec_grp, POLY, VECTOR, GRPDFT) }; int nstatic3 = array_size(static3); LiE/box/Makefile~0000644000175000017500000000072510303076367013114 0ustar hakanhakanCINCLUDES= -I. -I.. .SUFFIXES: %.o: %.c $(CC) -c $(CPPFLAGS) $(all-C-flags) $< objects=\ altdom.o branch.o centr.o closure.o contragr.o coxeter.o decomp.o defs.o\ diagram.o domchar.o factor.o grpdata.o lr.o matrix.o orbit.o\ plethysm.o sorting.o static3.o symg.o tensor.o weyl.o weylloop.o worbit.o .PHONY: all clean all: .last_compiled .last_compiled: $(objects) touch .last_compiled defs.o: defs.h # standard targets clean: rm -f *~ *.o .last_compiled LiE/box/decomp.c0000644000175000017500000000727310305606502012666 0ustar hakanhakan#include "lie.h" #define local static #define ACCMIN 8 static poly* sorted,* pos_acc,* neg_acc; local cmpfn_tp sav_cmpfn; /* to store suspended |cmpfn| */ local object sav_dfgrp; local simpgrp* the_g; local entry* cur_expon; void wt_init(index r) { sorted=copypoly(poly_null(r)); pos_acc=mkpoly(ACCMIN,r); neg_acc=mkpoly(ACCMIN,r); pos_acc->nrows=0; neg_acc->nrows=0; } void wt_ins(entry* wt, bigint* c, boolean neg) { if (c->size==0) { freemem(c); return; } { index i=searchterm(sorted,wt); if (i>=0) { clrshared(sorted->coef[i]); sorted->coef[i]= (neg ? sub : add)(sorted->coef[i],c); setshared(sorted->coef[i]); } else { poly** acc= neg ? &neg_acc : &pos_acc; index i=(*acc)->nrows; if (i==(*acc)->rowsize) { sorted=Add_pol_pol(sorted,*acc,neg); *acc=mkpoly(Max(sorted->nrows,ACCMIN),sorted->ncols); i=0; } copyrow(wt,(*acc)->elm[i],sorted->ncols); (*acc)->coef[i++]=c; setshared(c); (*acc)->nrows=i; } } } poly* wt_collect(void) { if (pos_acc->nrows>0) sorted=Add_pol_pol(sorted,pos_acc,false); else freemem(pos_acc); if (neg_acc->nrows>0) sorted=Add_pol_pol(sorted,neg_acc,true); else freemem(neg_acc); { poly* result=sorted; sorted=NULL; return result; } } local void set_weight_sorting(object g) { sav_cmpfn=cmpfn; sav_dfgrp=defaultgrp; cmpfn=height_decr; defaultgrp=g; } local poly* decompose_character(poly* ch) { wt_init(ch->ncols); /* for building result */ while (ch->coef[0]->size!=0) /* i.e., |while (ch!=0)| */ { bigint* c=ch->coef[0]; if (c->size<0) { cmpfn=sav_cmpfn; defaultgrp=sav_dfgrp; error ("Non-virtual decomposition failed.\n"); } { wt_ins(ch->elm[0],c,false); /* contribute weight to result */ c=copybigint(c,NULL); c->size= -c->size; ch=Addmul_pol_pol_bin(ch,Domchar_irr(ch->elm[0],NULL),c); } } { poly* result=wt_collect(); { cmpfn=sav_cmpfn; defaultgrp=sav_dfgrp; clrsorted(result); } return result; } } void char_init(object g) { set_weight_sorting(g); wt_init(Lierank(g)); } poly* char_decomp(void) { return decompose_character(wt_collect()); } poly* Decomp(poly* p) { poly* q=copypoly(p); freemem(p); clrsorted(q); set_weight_sorting(grp); return decompose_character(Reduce_pol(q)); } local void add_decomp_wt(entry* mu) { index i,r=the_g->lierank; boolean neg; for (i=0; ilierank); Weylloopinit(g); Weylloop(add_decomp_wt,lambda); Weylloopexit(); return wt_collect(); } local poly* vdecomp_irr(entry* lambda) { if (type_of(grp)==SIMPGRP) return simp_vdecomp_irr(lambda,&grp->s); if (simpgroup(grp)) return simp_vdecomp_irr(lambda,Liecomp(grp,0)); { poly* result; index i; { index td=grp->g.toraldim; lambda+=Ssrank(grp); result=mkpoly(1,td); copyrow(lambda,*result->elm,td); *result->coef=one; } for (i=grp->g.ncomp-1; i>=0; --i) /* traverse simple components in reverse order */ { simpgrp* g=Liecomp(grp,i); lambda-=g->lierank; result= Disjunct_mul_pol_pol(simp_vdecomp_irr(lambda,g),result); } return result; } } poly* Vdecomp(poly* p) { index i,r=Lierank(grp); poly* result=poly_null(r); cur_expon=mkintarray(r); /* large enough */ for (i=0; inrows; ++i) result=Addmul_pol_pol_bin(result,vdecomp_irr(p->elm[i]),p->coef[i]); freearr(cur_expon); return result; } LiE/box/closure.c0000644000175000017500000002576310305606502013077 0ustar hakanhakan#include "lie.h" #define local static #include #define two_lengths(type) (strchr("BCFG",type)!=NULL) #define grp_less(x,y) \ ((x)->lietype<(y)->lietype \ || (x)->lietype==(y)->lietype && (x)->lierank<(y)->lierank) #define opposite(a,b) adj[b][adj[b][0]==(a)] local void fundam(matrix* roots, index first, index* last); local index s; /* the current semisimple rank */ local simpgrp* simp_type(entry** m, entry n) { matrix* adjs=mkmatrix(n,3); entry** adj=adjs->elm /* |adj[i]| lists up to 3 neighbours of node |i| */ ,* norm=mkintarray(3*n) /* norms of roots */ ,* valency=&norm[n] /* valencies in Dynkin diagram */ ,* p=&valency[n]; /* permutation of |n| */ simpgrp* result; index i,j,k, a_val[4]={-1,-1,-1,-1}; /* |a_val[i]| is index of a node of valency |i|, if any */ if (n==0) error("empty input in simp_type\n"); { for (i=0;i=0;) { norm[i]= Norm(m[i]); /* where |Norm(x)==Inprod(x,x)/2| */ for (j=i; --j>=0;) if (Inprod(m[i],m[j])!=0) /* then valencies increase */ { if (valency[i]>=3 || valency[j]>=3) error ("valency >3 found\n"); adj[i][valency[i]++]=j; adj[j][valency[j]++]=i; /* update valencies and adjacencies */ } a_val[valency[i]]=i; /* valency of node |i| is now known */ } } if (a_val[3]<0) { index e; /* index of end node (|valency[e]<=1|) */ if (a_val[0]>=0) p[0]=e=a_val[0]; /* must be type $A_1$ */ else { if (a_val[1]>=0) p[0]=e=a_val[1]; /* other linear types */ else error("no end node found\n"); { k=p[1]=adj[e][0]; /* the unique neighbour of node |e| */ for(i=2;i=3 && norm[p[0]]!=norm[p[1]] || n==4 && norm[p[1]]=0; j--) if (valency[branch[j]]==1) end[end_count++]=branch[j]; if (end_count>1) { p[n-1]=end[1]; p[n-2]=end[0]; p[n-3]=a_val[3]; k=p[n-4]=branch[0]+branch[1]+branch[2]-p[n-1]-p[n-2]; /* the remaining branch */ for(i=n-5; i>=0; i--) { if (valency[k]!=2) error("unlinear Dn tail.\n"); p[i]=k=opposite(p[i+2],k); } result=mksimpgrp('D',n); } else if (end_count==1) { p[3]=a_val[3]; p[1]=end[0]; for (j=2; j>=0; j--) if (valency[branch[j]]==2) if (valency[opposite(a_val[3],branch[j])]==1) break; if (j<0) error("type E not recognised\n"); p[2]=branch[j]; p[0]=opposite(p[3],p[2]); p[4]=k=branch[0]+branch[1]+branch[2]-p[1]-p[2]; /* remaining branch */ for(i=5;i=0) /* then |p[i]| starts an untreated cycle */ { entry* mi=m[j=i]; /* record beginning of cycle */ while (p[j]!=i) { k=j; j=p[j]; m[k]=m[j]; p[k]= -1; } /* assign |m[j]=m[p[j]]| and advance */ m[j]=mi; p[j]= -1; /* close the cycle */ } freemem(adjs); freearr(norm); return result; } static void cycle_block(matrix* m, index first, index last, index amount) { entry** row=&m->elm[first]; index modulus=last-first,i,min_done=amount; if (amount>0 && modulus>amount) /* otherwise there is nothing to do */ for (i=0; i=modulus) j-=modulus; /* wrap downwards */ } while (j>=min_done || j>i && (min_done=j,true)); row[old_j]=row_i; /* close the cycle */ if (j!=i) error("System error cycling.\n"); } } local void long_close(matrix* m, index first, index last) { index i,j; entry* root_i,* root_j,* t=mkintarray(s); for (i=first; ielm[i]; if (Norm(root_i)>1) continue; for (j=i+1; jelm[j]; if (Norm(root_j)>1) continue; subrow(root_i,root_j,t,s); if (isroot(t)) if (isposroot(t)) { copyrow(t,root_i,s); break; } /* need not consider more |j|'s */ else add_xrow_to(root_j,-1,root_i,s); } } freearr(t); } matrix* Closure(matrix* m, boolean close, group* lie_type) { matrix* result; index i,j; group* tp=(s=Ssrank(grp), lie_type==NULL ? mkgroup(s) : lie_type); tp->toraldim=Lierank(grp); tp->ncomp=0; /* start with maximal torus */ m=copymatrix(m); if (close) if (type_of(grp)==SIMPGRP) close = two_lengths(grp->s.lietype); else { for (i=0; ig.ncomp; i++) if (two_lengths(Liecomp(grp,i)->lietype)) break; close= ig.ncomp; } { entry* t; for (i=0; inrows; i++) if (!isroot(t=m->elm[i])) error("Set of root vectors contains a non-root\n"); else if (!isposroot(t=m->elm[i])) for (j=0; jncols; j++) t[j]= -t[j]; /* make positive root */ Unique(m,cmpfn); } { index next; for (i=0; inrows; i=next) { index d,n=0; simpgrp* c; next=isolcomp(m,i); fundam(m,i,&next); if (close) long_close(m,i,next),fundam(m,i,&next); c=simp_type(&m->elm[i],d=next-i); { j=tp->ncomp++; while(--j>=0 && grp_less(tp->liecomp[j],c)) n += (tp->liecomp[j+1]=tp->liecomp[j])->lierank; tp->liecomp[++j]=c; tp->toraldim -= d; /* insert component and remove rank from torus */ cycle_block(m,i-n,next,n); /* move the |d| rows down across |n| previous rows */ } } } if (lie_type==NULL) return result=copymatrix(m),freemem(m),freemem(tp),result; else return freemem(m),(matrix*)NULL; /* |Cartan_type| doesn't need |m| */ } group* Carttype(matrix* m) { group* type=mkgroup(s=Ssrank(grp)); /* rank bounds number of components */ Closure(m,false,type); return type; } local void fundam(matrix* roots, index first, index* last) { index i,j,d; boolean changed; entry* t=mkintarray(s); matrix mm,* m=&mm; mm.elm=&roots->elm[first]; mm.nrows=*last-first; mm.ncols=roots->ncols; for (i=m->nrows-1; i>0; changed ? Unique(m,cmpfn),i=m->nrows-1 : --i) { entry* root_i=m->elm[i]; changed=false; for (j=i-1; j>=0; j--) { entry* root_j=m->elm[j]; entry c=Cart_inprod(root_j,root_i); if (c==2 && eqrow(root_j,root_i,s)) { cycle_block(m,j,m->nrows--,1); root_i=m->elm[--i]; } else if (c>0) { changed=true; { copyrow(root_j,t,s); add_xrow_to(t,-c,root_i,s); if (isposroot(t)) copyrow(t,root_j,s); else { j=i; c=Cart_inprod(root_i,root_j); copyrow(root_i,t,s); add_xrow_to(t,-c,root_j,s); if (isposroot(t)) copyrow(t,root_i,s); else { index k; entry* ln,* sh; /* the longer and the shorter root */ if (Norm(root_i)>Norm(root_j)) ln=root_i, sh=root_j; else ln=root_j, sh=root_i; switch (Norm(ln)) { case 2: subrow(ln,sh,sh,s); /* |sh=ln-sh| */ add_xrow_to(ln,-2,sh,s); /* |ln=ln-2*sh| */ break; case 3: /* |grp=@t$G_2$@>| now */ for (k=0; sh[k]==0; ++k) {} /* find the place of this $G_2$ component */ sh[k]=1; sh[k+1]=0; ln[k]=0; ln[k+1]=1; /* return standard basis of full system */ break; default: error("problem with norm 1 roots\n"); } } } } } } } cycle_block(roots,first+mm.nrows,roots->nrows,d=*last-first-mm.nrows); *last-=d; roots->nrows-=d; freearr(t); } matrix* Resmat(matrix* roots) { index i,j,k,r=Lierank(grp),s=Ssrank(grp), n=roots->nrows; vector* root_norms=Simproot_norms(grp); entry* norms=root_norms->compon; /* needed to compute $\<\lambda,\alpha[i]>$ */ matrix* root_images=Matmult(roots,Cartan()),* result=mkmatrix(r,r); entry** alpha=roots->elm,** img=root_images->elm,** res=result->elm; for (i=0; i=j) /* clear |v[k+1]| by unimodular column operations with column~|j| */ { entry u[3][2]; index l=0; u[0][1]=u[1][0]=1; u[0][0]=u[1][1]=0; u[2][1]=v[k]; u[2][0]=v[k+1]; if (v[k]<0) u[2][1]= -v[k], u[0][1]= -1; /* make |u[2][1]| non-negative */ do /* subtract column |l| some times into column |1-l| */ { entry q=u[2][1-l]/u[2][l]; for (i=0; i<3; i++) u[i][1-l]-=q*u[i][l]; } while (u[2][l=1-l]!=0); if (l==0) for (i=0; i<2; i++) swap(&u[i][0],&u[i][1]); { for (i=j; i$ */ } } freemem(root_norms); freemem(root_images); return result; } LiE/box/coxeter.c0000644000175000017500000003642310305606502013067 0ustar hakanhakan#include "lie.h" #define local static #define backup(i) (i=(i<=2 ? 0 : i-2)) #define Bh(x,y) (copyrow(x,v,s),copyrow(y,w,s),Bruhat(v,w)) #define P(x,y,e,d) (copyrow(x,v,s),copyrow(y,w,s),KL(v,w,e,d,s)) entry simp_inprod(entry* x,entry * y,simpgrp* g) { index i,j, r=g->lierank; entry* norm=(simp_proots(g),g->root_norm->compon); entry** cartan=g->cartan->elm; entry result=0; for (j=0; js); { index i,t=0,result=0; for (i=0; ig.ncomp; ++i) { simpgrp* g=Liecomp(grp,i); result+=simp_inprod(&x[t],&y[t],g); t+=g->lierank; } return result; } } entry simp_norm(entry* alpha, simpgrp* g) { index i,r=g->lierank; entry level=0,result; boolean neg; for (i=0; i=0); result=g->root_norm->compon[i]; if (neg) for(i=0; is); if (grp->g.ncomp==1) return simp_norm(alpha,Liecomp(grp,0)); { index i,j,t=0; for (i=0; ig.ncomp; ++i) { simpgrp* g=Liecomp(grp,i); index r=g->lierank; for (j=0; jlierank; entry* row=mkintarray(2*r),* col=&row[r]; { index norm_alpha=simp_norm(alpha,g); entry* norm=g->root_norm->compon; mulvecmatelm(alpha,g->cartan->elm,row,r,r); /* |alpha| on weight basis */ copyrow(alpha,col,r); for (i=0; ielm[offset+i][offset],-col[i],row,r); freearr(row); return m; } matrix* Reflection(entry* alpha) { index i,j,t=0; matrix* R=mat_id(Lierank(grp)); if (type_of(grp)==SIMPGRP) return simp_refl(alpha,&grp->s,R,0); if (grp->g.ncomp==1) return simp_refl(alpha,Liecomp(grp,0),R,0); for (i=0; ig.ncomp; ++i) { simpgrp* g=Liecomp(grp,i); index r=g->lierank; for (j=0; jlierank; do { while (lambda[i]>=0) if (++i==r) return l; /* find first negative entry */ simp_w_refl(lambda,i,g); ++l; backup(i); /* reflect and count, then back up */ } while(true); } index make_dominant(entry* lambda) { index i=0,l=0; index s=Ssrank(grp); /* do not affect the toral part */ if (s==0) return 0; /* this trivial case must be taken out */ do { while (lambda[i]>=0) if (++i==s) return l; w_refl(lambda,i); ++l; backup(i); } while(true); } local index dom_length(entry* lambda) { index l,s=Ssrank(grp); entry* x=mkintarray(s); copyrow(lambda,x,s); l=make_dominant(x); freearr(x); return l; } vector* Dominant(vector* lambda) { vector* result=copyvector(lambda); make_dominant(result->compon); return result; } index Length(vector* w) { index i,s=Ssrank(grp),l=0; entry* x=mkintarray(s),wi; for (i=0; incomp; ++i) if ((wi=w->compon[i]-1)>=0) { if (x[wi]>0) ++l; else --l; w_refl(x,wi); } freearr(x); return l; } vector* Wwordv(entry* lambda, index l) { index i=0,j=0,s=Ssrank(grp); entry* x=mkintarray(s); vector* result=mkvector(l>=0 ? l : dom_length(lambda)); copyrow(lambda,x,s); if (s==0) { freearr(x); return result; } do { while (x[i]>=0) if (++i==s) { freearr(x); return result; } w_refl(x,i); result->compon[j++]= i+1; backup(i); } while(true); } vector* Wwordm(matrix* m) { index i,l=0,s=Ssrank(grp); entry* x=mkintarray(2*s),* y=&x[s]; vector* result; for (i=0; ielm,x,s,s); /* |x=rho*@t$m\v_{s\times s}$@>| */ i=0; if (s>0) do { while (x[i]>=0) if (++i==s) goto finish; w_refl(x,i); w_refl(y,i); ++l; backup(i); } while(true); finish: result=Wwordv(y,l); freearr(x); { matrix* check=Weyl_mat(result); index r=Lierank(grp); for (i=0; ielm[i],check->elm[i],r)) error("Matrix does not correspond to a Weyl group element.\n"); freemem(check); } return result; } vector* Canonical(vector* w) { index i,l=w->ncomp,s=Ssrank(grp),wi; entry* x=mkintarray(s); vector* result; for (i=0; i=0; --i) /* apply reverse of |w| to |x| */ if ((wi=w->compon[i]-1)>=0) { w_refl(x,wi); if (x[wi]>0) l-=2; } else --l; result=Wwordv(x,l); freearr(x); return result; } matrix* Canonicals(matrix* m) { index k,n=m->nrows,s=Ssrank(grp); matrix* result=mkmatrix(n,m->ncols); entry* x=mkintarray(s); for (k=0; kelm[k]; index i,l=m->ncols,wi; vector* t; for (i=0; i=0; --i) if ((wi=w[i]-1)<0) --l; else { if (x[wi]<0) l-=2; w_refl(x,wi); } t=Wwordv(x,l); copyrow(t->compon,result->elm[k],l); freemem(t); for (i=l; incols; ++i) result->elm[k][i]=0; /* fill out with 0's */ } freearr(x); return result; } matrix* Filter_dom_m(matrix* m) { index i,j,s=Ssrank(grp),count=0; entry* inx=mkintarray(m->nrows); for (i=0; inrows; ++i) /* get indices of dominant rows into |inx| */ { for (j=0; jelm[i][j]<0) break; if (j==s) inx[count++]=i; } { index r=m->ncols; matrix* result=mkmatrix(count,r); for (i=0; ielm[inx[i]],result->elm[i],r); freearr(inx); return result; } } poly* Filter_dom(poly* p) { index i,j,s=Ssrank(grp),count=0; entry* inx=mkintarray(p->nrows); for (i=0; inrows; ++i) /* get indices of dominant rows into |inx| */ { for (j=0; jelm[i][j]<0) break; if (j==s) inx[count++]=i; } if (count==0) { freearr(inx); return poly_null(p->ncols); } { index r=p->ncols; poly* result=mkpoly(count,r); for (i=0; ielm[inx[i]],result->elm[i],r); result->coef[i]=p->coef[inx[i]]; setshared(result->coef[i]); } freearr(inx); return result; } } local entry* fix_vec (vector* I, index s) { index i; entry* x=mkintarray(s); for (i=0; incomp; i++) { entry e=I->compon[i]; if (e<=0 || e>s) error("Reflection %ld is out of range.\n",(long)e); x[e-1]=0; /* now reflection $r_e$ stabilises |x| */ } return x; } vector* L_red(vector* L, entry* w, index lw) { index i,s=Ssrank(grp),l=lw; /* current length of word; decreases during reduction */ entry* x=fix_vec(L,s),* y=mkintarray(s); /* current vector and temporary */ for (i=0; i0) /* act on~$x$ with $w_i$; test if length decreased */ { index j=i; copyrow(x,y,s); /* make a temporary copy of~|x| */ do if (w[--j]!=0) if (y[w[j]-1]<0) w_refl(y,w[j]-1); else break; while (true); w[j]=w[i]=0; l-=2; /* cancel reflections by exchange condition */ } } freearr(x); freearr(y); { vector* result=mkvector(l); entry* res=result->compon; for (i=0; incomp; entry* w=mkintarray(lw); copyrow(v->compon,w,lw); result=L_red(empty,w,lw); freemem(empty); freearr(w); return result; } vector* LR_red(vector* L,entry* w,index lw,vector* R) { { vector* t=L_red(L,w,lw); lw=t->ncomp; copyrow(t->compon,w,lw); freemem(t); } { index i,l=lw; entry* x=fix_vec(R,Ssrank(grp)); for (i=lw-1; i>=0; i--) /* see if |wi| can be eliminated */ { entry wi=w[i]-1; if (x[wi]==0) { w[i]=0; --l; } /* |wi| stabilises |x|, delete it */ else w_refl(x,wi); /* we have |x[wi]>0|; the length increases */ } freearr(x); { vector* result=mkvector(l); entry* res=result->compon; for (i=0; ielm,delta,s,s); freemem(ic); freearr(t); for (d=0, i=0; i0; backup(i)) { while (y[i]>=0) ++i; /* find first |y[i]<0|; it exists */ { w_refl(y,i); delta[i]-=y[i]; d-=y[i]; if (x[i]<0) { w_refl(x,i); delta[i]+=x[i]; d+=x[i]; } } if (delta[i]<0) { freearr(delta); return false; } /* because we no longer have $y\prec x$ */ } freearr(delta); return true; /* |delta==0|, so |x| and |y| have become equal */ } boolean Bh_leq(vector* v,vector* w) { index i,s=Ssrank(grp); entry* x=mkintarray(2*s),* y=&x[s]; boolean result; for (i=0; i0) w_refl(x,wj); else break; } if (j==l) inx[n_desc++]=i; /* if reduced, record |i| */ } } { matrix* result=mkmatrix(n_desc,l-1); index i,j; for (i=0; ielm[i]; for (j=0; j0) w_refl(x,wj); else break; } if (j==l && (copyrow(lwb,y,s),Bruhat(y,x))) inx[n_desc++]=i; } } { matrix* result=mkmatrix(n_desc,l-1); index i,j; for (i=0; ielm[i]; for (j=0; jelm[0],-1); entry* w=word->compon; index i,j,k,l=word->ncomp,n_desc=0; matrix* descs=mkmatrix(((*m)->nrows)*l+1,s); entry* x=mkintarray(2*s),* y=&x[s]; /* working arrays */ for (k=0; ; w=(word=Wwordv((*m)->elm[k],l))->compon) { for (i=0; i=0; --j) if (j!=i) { entry wj=w[j]-1; if (x[wj]>0) w_refl(x,wj); else break; } if (j<0 && (copyrow(lwb,y,s),copyrow(x,descs->elm[n_desc],s),Bruhat(y,x))) ++n_desc; } freemem(word); if (++k==(*m)->nrows) break; } descs->nrows=n_desc; freearr(x); freemem(*m); *m=Unique(descs,cmpfn); } static poly* q,* q_1; /* |q| respectively |q-1|, when initialised */ void make_q (void) { (q=mkpoly(1,1))->elm[0][0]=1; *q->coef=one; setshared(q); /* $X^{[1]}$ means |q| */ q_1= Add_pol_pol(q,poly_one(1),true); setshared(q_1); /* $X^{[1]}-X^{[0]}$ means |q-1| */ } void clear_q (void) { clrshared(q); freepol(q); clrshared(q_1); freepol(q_1); } local poly* R(entry* x, entry* y, index k, index d, index s) /* modifies |x| and |y| */ { index i; entry* v=mkintarray(2*s),* w=&v[s]; poly* sum=poly_null(1); while (d>0) /* |d==length(y)-length(x)| */ { if (!Bh(x,y)) { freearr(v);return sum;} for (i=0; ; backup(i)) { do { if (x[i]<0 && y[i]<0) break;} while (++i=0; ++i) {} { w_refl(y,i); copyrow(x,v,s); copyrow(y,w,s); sum=Add_pol_pol(sum,Mul_pol_pol(q_1,R(v,w,k,d-1,s)),false); } w_refl(x,i); d-=2; ++k; /* repeat with $x\K xs_i$, $y\K ys_i$, adjusted~|d|, and increased~|k| */ } freearr(v); if (d==0 && eqrow(x,y,s)) /* if |x==y|, add final $q^k$ */ { poly* q_k=copypoly(q); q_k->elm[0][0]=k; sum= Add_pol_pol(sum,q_k,false); } return sum; } poly* Rpoly(vector* x,vector* y) { index i,s=Ssrank(grp); entry* v=mkintarray(2*s),* w=&v[s]; poly* result; for (i=0; icoef[0]=one; qe->elm[0][0]=e; freearr(v); return qe; } do { for (i=0; ; backup(i)) { do { if (x[i]>0 && y[i]<0) break; } while (++i=0; ++i) {} /* find $i$ with $ys_ielm[0],s); Bh_descs(&level,x,s); --d; /* |d==l(z)-l(x)| */ do { for (j=0; jnrows; ++j) { entry* z=level->elm[j]; if (z[i]<0) { poly* Pzy=P(z,y,0,2*c-1); if (Pzy->nrows!=0 && Pzy->elm[0][0]==c-1 && Pzy->coef[0]->size!=0) /* |mu(z,y)!=0| */ { bigint* mu=sub(null,Pzy->coef[0]); freepol(Pzy); result=Addmul_pol_pol_bin(result,P(x,z,e+c,d),mu); } } } if (d<2) { freemem(level); break;} /* we cannot go down 2 more levels */ Bh_descs(&level,x,s); Bh_descs(&level,x,s); d-=2; ++c; } while(true); } freearr(v); return result; } poly* KLpoly(vector* x,vector* y) { index i,s=Ssrank(grp); entry* v=mkintarray(2*s),* w=v+s; poly* result; for (i=0; ilierank; entry* res=mkintarray(r),* ones=mkintarray(r); for (i=0; ielm,ones,res,r,r); freearr(ones); return res; } local matrix* simp_domw(entry* lambda, simpgrp* g, vector** levels) { index r=g->lierank; matrix* posroots=Matmult(simp_proots(g),simp_Cartan(g)); entry* x=mkintarray(r); matrix* weights=mkmatrix(EXTEND,r); vector* wt_levels; { entry* rho_hat=simp_level_vec(g); index i,lev=0; for (i=0; ielm[0],r); wt_levels->compon[0]=0; wt_levels->compon[1]=1; for (lev=1; levncomp-1; wt_levels->compon[++lev]=lev_start=end) for (k=0,d=1; knrows; ++k) /* try roots by increasing level */ if (k==g->level->compon[d] && ++d>lev) break; /* now root $\alpha_k$ has level |d| */ else { index w; /* index of a dominant weight $\mu\below\lambda$ at level |lev-d| */ for (w=wt_levels->compon[lev-d]; wcompon[lev-d+1]; ++w) if (pos_subrow(weights->elm[w],posroots->elm[k],x,r)) /* |x=mu-@t$\alpha_k$@>| must be dominant */ { index i; for (i=lev_start; ielm[i],r)) goto next_wt; if (end==weights->rowsize) { weights->nrows=end; weights=extendmat(weights); } copyrow(x,weights->elm[end++],r); next_wt: {} } } weights->nrows=end; } if (levels!=NULL) *levels=wt_levels; else freemem(wt_levels); freearr(x); freemem(posroots); return weights; } local index locate(entry* mu,entry** m,entry* rho_hat,entry* level,simpgrp* g) { index l=0,i,r=g->lierank; entry* lambda=m[0]; /* the highest weight */ for (i=0; i=0) for (i=level[l]; ilierank,n=g->roots->nrows; entry** posr=g->roots->elm; for (i=0; ilevel->ncomp-1; ++l) /* traverse all root levels except the highest */ for (j=0; jlevel->compon[l-1]; ilevel->compon[l]; ++i) if (mults[i]!=0) { entry e=-posr_weight[i][j]; if (e>0) { ignore_intr(); posr[i][j]+=e; k=find_root(posr[i],l+e,g); posr[i][j]-=e; allow_intr(); assert(k>=0); mults[k]+=mults[i]; mults[i]=0; } } } local long c(entry* mu, simpgrp* g) { index a,r=g->lierank,i,j; entry** ic=simp_icart(g)->elm,* n=g->root_norm->compon; for (a=0,j=0; jlierank; bigint* denom=copybigint(one,NULL),* numer=copybigint(one,NULL); matrix* posr=simp_proots(g); entry* norm=g->root_norm->compon; for (i=0; inrows; ++i) { entry* alpha=posr->elm[i]; entry den=0,num=0; for (j=0; js); if (simpgroup(grp)) return simp_dim_irr(lambda,Liecomp(grp,0)); { index i,s=0; bigint* res=one; for (i=0; ig.ncomp; ++i) { simpgrp* g=Liecomp(grp,i); res=mult(res,simp_dim_irr(&lambda[s],g)); s+=g->lierank; } return res; } } bigint* Dim(poly* p) { index i,r=p->ncols; bigint* res=null; entry* lambda= mkintarray(r); for (i=0; inrows; ++i) { copyrow (p->elm[i],lambda,r); make_dominant(lambda); res=add(res,mult(p->coef[i],DimIrr(lambda))); } freearr(lambda); return res; } matrix* Domweights(vector* lambda) { if (type_of(grp)==SIMPGRP) return simp_domw(lambda->compon,&grp->s,NULL); if (simpgroup(grp)) return simp_domw(lambda->compon,grp->g.liecomp[0],NULL); { index i,j,n=grp->g.ncomp,r=Lierank(grp); matrix** M=alloc_array(matrix*,n); for (i=0,j=0; ig.liecomp[i++]->lierank) M[i]=simp_domw(&lambda->compon[j],grp->g.liecomp[i],NULL); return Cartes_prod(M,n,&lambda->compon[j],r); } } matrix* Cartes_prod(matrix** M,index n,entry* toral,index r) { index i=0,j=0; entry* pos,* offset,* lambda; matrix* result; { index i, s=0, p=1; /* sum of row sizes and product of column sizes of the |M[i]| */ pos=mkintarray(2*n+r),offset=&pos[n],lambda=&offset[n]; for (i=0; incols; p*=M[i]->nrows; } result = mkmatrix(p,r); copyrow(toral,&lambda[s],r-s); /* toral part of working vector */ } do /* now |i| indicates first simple factor whose entries in |lambda| need to be updated */ { for (;ielm[pos[i]],&lambda[offset[i]],M[i]->ncols); /* update |lambda| */ copyrow(lambda,result->elm[j++],r); /* copy full vector |lambda| to result */ while (--i>=0 && ++pos[i] == M[i]->nrows) pos[i]=0; /* advance |pos| to match |j| */ } while (i>=0); /* full circle when |pos| returns to all zeroes */ freearr(pos); { while (++iroots->nrows); index r=g->lierank; entry* x=mkintarray(2*r),* y=&x[r]; entry* rho_hat=simp_level_vec(g); index last_row= muo==NULL ? dom_w->nrows-1 : locate(muo,dom_w->elm,rho_hat,wt_levels->compon,g); dom_w->coef[0]=one; /* initialise first multiplicity to 1 */ for (k=1; k<=last_row; ++k) { index i; entry* mu=dom_w->elm[k]; bigint* sum=null; long denominator=(c_lambda-c(mu,g))/(2*det); gather_roots(mu,roots->elm,g,mults); /* compute |mults| for stabiliser group $W_\mu$ */ for (i=0; inrows; ++i) if (mults[i]>0) { entry* alpha=roots->elm[i]; { index k; entry* a=g->roots->elm[i]; entry inp=0,d=0; entry* norm=g->root_norm->compon; for (k=0; kelm,rho_hat,wt_levels->compon,g))<0) break; /* not found */ sum=add(sum,mul1(copybigint(dom_w->coef[k],NULL),mults[i]*(inp+=d))); } while(true); } } dom_w->coef[k]=quotient(sum,entry2bigint(denominator)); setshared(dom_w->coef[k]); } freemem(wt_levels); freemem(roots); freearr(mults); freearr(x); freearr(rho_hat); if (muo==NULL) return dom_w; else { poly* mul=poly_null(0); /* polynomial in |0| indeterminates */ if (last_row<0) return mul; mul=copypoly(mul); mul->coef[0]=dom_w->coef[last_row]; setshared(mul->coef[0]); freemem(dom_w); return mul; } } poly* Domchar_irr(entry* lambda,entry* muo) { index i,j,r=Lierank(grp),s=Ssrank(grp); poly* result; if (type_of(grp)==SIMPGRP) return simp_domchar(lambda,muo,&grp->s); if (simpgroup(grp)) return simp_domchar(lambda,muo,Liecomp(grp,0)); if (muo==NULL) { result=mkpoly(1,r-s); copyrow(&lambda[s],result->elm[0],r-s); *result->coef=one; } else if (eqrow(&lambda[s],&muo[s],r-s)) result=poly_one(0); else return poly_null(0); for (i=grp->g.ncomp-1,j=s; i>=0; --i) /* traverse components in reverse order */ { simpgrp* g=grp->g.liecomp[i]; j-=g->lierank; result= Disjunct_mul_pol_pol (simp_domchar(&lambda[j],muo==NULL?NULL:&muo[j],g),result); } return result; } poly* Domchar_p(poly* p) { index i,r=p->ncols; poly* result=poly_null(r); for (i=0; inrows; ++i) { testdom(p->elm[i],grp); result=Addmul_pol_pol_bin(result,Domchar_irr(p->elm[i],NULL),p->coef[i]); } return result; } entry* Lv(object g) { if (type_of(g)==SIMPGRP) return simp_level_vec(&g->s); if (simpgroup(g)) return simp_level_vec(Liecomp(g,0)); { index i,j=0,r=Lierank(g); entry* result=mkintarray(r); for(i=0; ig.ncomp; ++i) { simpgrp* s=g->g.liecomp[i]; entry* l=simp_level_vec(s); copyrow(l,&result[j],s->lierank); freearr(l); j+=s->lierank; } for(i=0; ig.toraldim; ++i) result[j+i]=0; return result; } } LiE/box/domchar.h0000644000175000017500000000055110305606502013031 0ustar hakanhakan bigint* simp_dim_irr(entry* lambda,simpgrp* g); bigint* DimIrr(entry* lambda); bigint* Dim(poly* p); matrix* Cartes_prod(matrix** M,index n,entry* toral,index r); matrix* Domweights(vector* lambda); poly* simp_domchar(entry* lambda,entry* muo,simpgrp* g); poly* Domchar_irr(entry* lambda,entry* muo); poly* Domchar_p(poly* p); entry* Lv(object g); LiE/box/factor.c0000644000175000017500000000246210305606502012670 0ustar hakanhakan#include "lie.h" #define trial_limit 32768U static digit inc[] = { 1, 2, 2, 4, 2, 4, 2, 4, 6, 2, 6 }; /* differences between members of $(\Zed/30)^\ast$ */ object Factor(bigint* num) { num=copybigint(num,NULL); if (num->size<0) { Printf("- "); num->size=-num->size; } { bigint* temp=mkbigint(num->size); digit p; int i=0; if (num->size==0) { Printf("0"); goto quit; } for (p=2; p<=trial_limit; p+= inc[i++]) { if (i==array_size(inc)) i=3; /* after |37-31| wrap to difference |11-7| */ if (copybigint(num,temp),div1(temp,p)==0) { index n; digit pn=p; int e=1; copybigint(temp,num); for (n=1; pn<=MaxDigit/p; ++n) pn*=p; /* highest $p^n$ fitting in |digit| */ for (; div1(temp,pn)==0; e+=n) copybigint(temp,num); /* find factors $p^n$ */ if (n>1) /* then there might be some factors |p| left */ for (copybigint(num,temp); div1(temp,p)==0; ++e) copybigint(temp,num); /* factors |p| */ Printf("%ld",(long)p); if (e>1) Printf("^%ld",(long)e); if (cmp1(num,1)==0) goto quit; /* last factor was found */ Printf(" * "); } } printbigint(num,0); if (num->size>2) Printf(" (Last factor need not be a prime)"); quit: Printf("\n"); freemem(num); freemem(temp); } return (object) NULL; } LiE/box/grpdata.c0000644000175000017500000003316210305606502013035 0ustar hakanhakan#include "lie.h" #define local static boolean wronggroup(char lietype,index rank) { return lietype=='T' ? rank<0 : lietype=='A' ? rank<1 : lietype=='B' ? rank<2 : lietype=='C' ? rank<2 : lietype=='D' ? rank<3 : lietype=='E' ? rank<6 || rank>8 : lietype=='F' ? rank!=4 : rank!=2; } boolean simpgroup(object g) { return (g->g.toraldim==0 && g->g.ncomp==1); } index Lierank(object grp) { index i,r; if (type_of(grp)==SIMPGRP) return grp->s.lierank; r=grp->g.toraldim; for (i=0; ig.ncomp; ++i) r += (Liecomp(grp, i))->lierank; return r; } index Ssrank(object g) /* Semisimple rank */ { index i,r=0; if (type_of(g)==SIMPGRP) return g->s.lierank; for (i=0; ig.ncomp; ++i) r += (Liecomp(g,i))->lierank; return r; } matrix* simp_Cartan(simpgrp* g) { if (g->cartan!=NULL) return g->cartan; { entry r=g->lierank; matrix* cartan=g->cartan=mat_null(r,r); entry** m=cartan->elm; setlonglife(cartan); /* make Cartan matrix permanent */ { index i; m[0][0]=2; for (i=1; ilietype) { case 'B': m[r-2][r-1]= -2; break; case 'C': m[r-1][r-2]= -2; break; case 'D': m[r-3][r-1]=m[r-1][r-3]= -1; m[r-2][r-1]=m[r-1][r-2]=0; break; case 'E': m[0][1]=m[1][0]=m[1][2]=m[2][1]=0; m[0][2]=m[2][0]=m[1][3]=m[3][1]= -1; break; case 'F': m[1][2]= -2; break; case 'G': m[1][0]= -3; } return cartan; } } matrix* Cartan(void) { if (type_of(grp)==SIMPGRP) return simp_Cartan(&grp->s); if (simpgroup(grp)) return simp_Cartan(Liecomp(grp,0)); { index i,j, t=0; matrix* cartan=mat_null(Ssrank(grp),Lierank(grp)); for (i=0; ig.ncomp; ++i) { index r=Liecomp(grp,i)->lierank; entry** c=simp_Cartan(Liecomp(grp,i))->elm; for (j=0; jelm[t+j][t],r); t+=r; } return cartan; } } entry simp_detcart(simpgrp* g) { char t=g->lietype; index r=g->lierank; return t=='A' ? r+1 : t=='B' || t=='C' ? 2 : t=='D' ? 4 : t=='E' ? 9-r : 1; } entry Detcartan(void) { if (type_of(grp)==SIMPGRP) return simp_detcart(&grp->s); { index i; entry result=1; for (i=0; ig.ncomp; ++i) result *= simp_detcart(Liecomp(grp,i)); return result; } } matrix* simp_icart(simpgrp* g) { if (g->icartan) return g->icartan; { index i, j, r=g->lierank; matrix* icartan=g->icartan=mkmatrix(r,r); entry** m=icartan->elm; setlonglife(icartan); /* permanent data */ switch (g->lietype) { case 'A': for (i=0; ielm; index k,t=0; entry det=Detcartan(); /* product of determinants of simple factors */ for (k=0; kg.ncomp; ++k) { simpgrp* g=Liecomp(grp,k); index i,j,r=g->lierank; entry** a=simp_icart(g)->elm; entry f=det/simp_detcart(g); /* multiplication factor */ for (i=0; iexponents!=NULL) return g->exponents->compon; { static entry exp_E[3][7] = {{4,5,7,8,11},{5,7,9,11,13,17},{7,11,13,17,19,23,29}} , exp_F4[3] = {5,7,11}; index i,r=g->lierank; entry* e=(g->exponents=mkvector(r))->compon; setlonglife(g->exponents); e[0]=1; switch (g->lietype) { case 'A': /* $1,2,3,\ldots,r$ */ for (i=1; is); return grp->s.exponents; } if (simpgroup(grp)) { simp_exponents(Liecomp(grp,0)); return Liecomp(grp,0)->exponents; } { index i,t=0; vector* v=mkvector(Lierank(grp)); entry* e=v->compon; { for (i=0; ig.ncomp; ++i) { simpgrp* g=Liecomp(grp,i); index r=g->lierank; copyrow(simp_exponents(g),&e[t],r); t+=r; } for (i=0; ig.toraldim; ++i) e[t+i]=0; } return v; } } index simp_numproots(simpgrp* g) { index r=g->lierank; return r*(1+simp_exponents(g)[r-1])/2; } index Numproots(object grp) /* should really return bigint */ { if (type_of(grp)==SIMPGRP) return simp_numproots(&grp->s); { index i,d=0; for (i=0; ig.ncomp; ++i) d += simp_numproots(Liecomp(grp,i)); return d; } } matrix* simp_proots(simpgrp* g) { if (g->roots!=NULL) return g->roots; { index r=g->lierank,l,i,last_root; entry** cartan=simp_Cartan(g)->elm; entry** posr=(g->roots=mkmatrix(simp_numproots(g),r))->elm; entry* level=(g->level=mkvector(simp_exponents(g)[r-1]+1))->compon; entry* norm=(g->root_norm=mkvector(g->roots->nrows))->compon; entry* alpha_wt=mkintarray(r); /* space to convert roots to weight coordinates */ setlonglife(g->roots), setlonglife(g->level), setlonglife(g->root_norm); /* permanent data */ { index i,j; for (i=0; ilietype) /* here are the exceptions */ { case 'B': for (i=0; ilevel[l]; ++l) { level[l+1]=last_root; /* set beginning of a new level */ for (i=level[l]; i$ */ for (j=0; j1 || norm[j]>1) continue; /* both roots must be short now */ else if (strchr("ADE",g->lietype)!=NULL) continue; /* but long roots must exist */ else if (alpha_wt[j]>0) if (g->lietype!='G'||alpha_wt[j]!=1) continue; else new_norm=3; /* $[2,1]\to[3,1]$ for $G_2$ */ else if (alpha[j]==0) continue; /* $\alpha-\alpha_j$ should not have a negative entry */ else { { --alpha[j]; for (k=level[l-1]; kroots; } } matrix* Posroots(object grp) { if (type_of(grp)==SIMPGRP) return simp_proots(&grp->s); if (simpgroup(grp)) return simp_proots(Liecomp(grp,0)); { index i,j,t1=0,t2=0; matrix* result=mat_null(Numproots(grp),Ssrank(grp)); entry** m=result->elm; for (i=0; ig.ncomp; ++i) { matrix* posr=simp_proots(Liecomp(grp,i)); index r=Liecomp(grp,i)->lierank; for (j=0; jnrows; ++j) copyrow(posr->elm[j],&m[t1+j][t2],r); t1+=posr->nrows; t2+=r; } return result; } } vector* Highroot(simpgrp* g) { matrix* posr=simp_proots(g); index r=g->lierank; vector* high=mkvector(r); copyrow(posr->elm[posr->nrows-1],high->compon,r); return high; } vector* Simproot_norms(object grp) { if (type_of(grp)==SIMPGRP) { simp_proots(&grp->s); return grp->s.root_norm; } { index i; for (i=0; ig.ncomp; ++i) simp_proots(Liecomp(grp,i)); } if (grp->g.ncomp==1) return Liecomp(grp,0)->root_norm; { index i,t=0; vector* result=mkvector(Ssrank(grp)); for (i=0; ig.ncomp; ++i) { simpgrp* g=Liecomp(grp,i); index r=g->lierank; copyrow(g->root_norm->compon,&result->compon[t],r); t+=r; } return result; } } static void set_simp_adjoint(entry* dst,simpgrp* g) { index r=g->lierank; vector* high=Highroot(g); mulvecmatelm(high->compon,g->cartan->elm,dst,r,r); freemem(high); } poly* Adjoint(object grp) { index i,j,r=Lierank(grp) ,n=type_of(grp)==SIMPGRP ? 1: grp->g.ncomp+(grp->g.toraldim!=0); poly* adj= mkpoly(n,r); for (i=0; icoef[i]=one; for (j=0; jelm[i][j]=0; } if (type_of(grp)==SIMPGRP) set_simp_adjoint(adj->elm[0],&grp->s); else { index offs=0; simpgrp* g; for (i=0; ig.ncomp; offs+=g->lierank,++i) set_simp_adjoint(&adj->elm[i][offs],g=Liecomp(grp,i)); if (grp->g.toraldim!=0) { adj->coef[i]=entry2bigint(grp->g.toraldim); setshared(adj->coef[i]); } } return adj; } entry Dimgrp(object grp) { return Lierank(grp) + 2*Numproots(grp); } matrix* Center(object grp) { index i,j,R=Lierank(grp),n_gen; for (n_gen=grp->g.toraldim,i=0; ig.ncomp; ++i) { simpgrp* g=Liecomp(grp,i); if (simp_detcart(g)>1) n_gen+=1+(g->lietype=='D' && g->lierank%2==0); } { matrix* res=mat_null(n_gen,R+1); entry** m=res->elm; index k=0,s=0; for (j=0; jg.ncomp; ++j) { simpgrp* g=Liecomp(grp,j); index n=g->lierank; entry d=simp_detcart(g); if (d>1) { switch (g->lietype) { case 'A': for (i=0; ig.toraldim; ++i) m[k++][s+i]=1; assert(k==n_gen); return res; } } index find_root(entry* alpha, entry level, simpgrp* g) { index i,r=g->lierank; matrix* posr=simp_proots(g); for (i=g->level->compon[level-1]; ilevel->compon[level]; ++i) if (eqrow(alpha,posr->elm[i],r)) return i; return -1; /* not found */ } local boolean simp_isroot(entry* alpha, simpgrp* g) { index i,r=g->lierank; entry level=0; boolean neg,result=false; for(i=0; i=0; if (neg) for(i=0; is); if (grp->g.ncomp==1) return simp_isroot(alpha,Liecomp(grp,0)); for (i=0; ig.ncomp; ++i) { simpgrp* g=Liecomp(grp,i); index r=g->lierank; for (j=0; j0 || !simp_isroot(alpha,g)) return false; else { ++n_parts; break; } alpha+=r; } return n_parts==1; /* |alpha| is root if supported on 1 simple component */ } void checkroot(entry* alpha) { if (!isroot(alpha)) { printarr(alpha,Ssrank(grp)); error (" is not a root.\n"); } } boolean isposroot(entry* alpha) { index i,s=Ssrank(grp); for (i=0; i0; assert(false); return false; /* to avoid compiler warnings */ } LiE/box/grpdata.h0000644000175000017500000000136110305606502013036 0ustar hakanhakan boolean wronggroup(char lietype,index rank); boolean simpgroup(object g); index Lierank(object grp); index Ssrank(object g); matrix* simp_Cartan(simpgrp* g); matrix* Cartan(void); entry simp_detcart(simpgrp* g); entry Detcartan(void); matrix* simp_icart(simpgrp* g); matrix* Icartan(void); vector* Exponents(object grp); index simp_numproots(simpgrp* g); index Numproots(object grp); matrix* simp_proots(simpgrp* g); matrix* Posroots(object grp); vector* Highroot(simpgrp* g); vector* Simproot_norms(object grp); poly* Adjoint(object grp); entry Dimgrp(object grp); matrix* Center(object grp); index find_root(entry* alpha, entry level, simpgrp* g); boolean isroot(entry* alpha); void checkroot(entry* alpha); boolean isposroot(entry* alpha); LiE/box/lr.c0000644000175000017500000000675010305606502012033 0ustar hakanhakan#include "lie.h" poly* LR_tensor_irr(entry* lambda,entry * mu, index n) { index i,j; entry* nu; entry** T; if (n==0) return poly_one(0); { nu=&mkintarray(n+1)[1]; copyrow(lambda,nu,n); nu[-1]=lambda[0]+mu[0]; T=alloc_array(entry*,n+1); for (i=0;i<=n;++i) /* allocate row |T[i]| and place sentinel before it */ { T[i]= &mkintarray(mu[i==0?0:i-1]+1)[1]; T[i][-1]=n-1-i; } for (i=0,j=mu[0]-1; j>=0; --j) { while (ij) ++i; /* find first |i| with |mu[i]<=j| */ T[i][j]=-1; /* place sentinel at bottom of column |j| */ } } wt_init(n); /* prepare to collect terms with exponents of size~|n| */ { j=-1; for (i=n-1; i>0 && mu[i]==0; --i) {} /* move to initial position */ recurse: /* recursive starting point; */ if (++j>=mu[i] &&(j=0,--i<0)) /* move to next empty position, if any */ wt_ins(nu,one,false); /* if not, |T| is full; contribute |nu| once */ else { index k= T[i+1][j]; entry prev= nu[k]; do { while (nu[++k]==prev) {} /* find next |k| with |nu[k]]| */ ++nu[T[i][j]=k]; goto recurse; /* insert |k| into |T| and extend partition |nu|; recurse */ resume: prev= --nu[k=T[i][j]]; /* restore |k| and |nu|; set |prev=nu[k]| */ } while (prev>nu[T[i][j-1]]); /* if so, there are still corners of |nu| to try */ } if (j==0) j= ++i=0) goto resume; /* do return jump unless empty row is reached */ } { --nu; freearr(nu); for (i=0;i<=n;i++) { entry* t=&T[i][-1]; freearr(t); } freearr(T); } return wt_collect(); /* return sum of all contributed terms */ } poly* LR_tensor(poly* p,poly* q) { index i,j,n=p->ncols; poly* res=poly_null(n); for (i=0; inrows; ++i) for (j=0; jnrows; ++j) res=Addmul_pol_pol_bin(res,LR_tensor_irr(p->elm[i],q->elm[j],n) ,mult(p->coef[i],q->coef[j])); return res; } vector* From_Part_v (entry* lambda, index n) { index i; vector* result=mkvector(n-1); entry* res=result->compon; for (i=0; ielm; for (i=0; inrows,n=p->ncols; poly* result=mkpoly(n_rows,n-1); entry** lambda=p->elm; entry** res=result->elm; for (i=0; icoef[i]=p->coef[i]; setshared(p->coef[i]); /* copy coefficient */ for (j=0; jcompon; entry sum=0; while (lambda[i]=sum, --i>=0) sum+=wt[i]; return result; } matrix* To_Part_m (entry** wt, index n_rows, index n) { index i; matrix* result=mkmatrix(n_rows,n+1); entry** lambda=result->elm; for (i=0; i=0) sum+=wt[i][j]; } return result; } poly* To_Part_p (poly* p) { index i,n_rows=p->nrows,n=p->ncols; entry** wt=p->elm; poly* result=mkpoly(n_rows,n+1); entry** lambda=result->elm; for (i=0; icoef[i]=p->coef[i]; setshared(p->coef[i]); while (lambda[i][j]=sum, --j>=0) sum+=wt[i][j]; } return Reduce_pol(result); } LiE/box/plethysm.c0000644000175000017500000000516510305606502013262 0ustar hakanhakan#include "lie.h" poly* Adams(index n,poly* p) { if (n==1) return p; /* avoid work in this trivial case */ { index i,j, r=Lierank(grp); poly* dom_ch=Domchar_p(p); for (i=0; inrows; ++i) for (j=0; jelm[i][j] *= n; { poly* result=Vdecomp(dom_ch); freepol(dom_ch); return result; } } } poly* SAtensor(boolean alt,index m,poly* p) { index n,r=Lierank(grp); poly** adams,** q,* result; if (m==0) return poly_one(r); else if (m==1) return p; adams=alloc_array(poly*,m+1); for (n=1; n<=m; ++n) adams[n]=Adams(n,p); q=alloc_array(poly*,m+1); q[0]=poly_one(r); for (n=1; n<=m; ++n) { { index i; q[n]=Tensor(p,q[n-1]); /* the initial term of the summation */ for (i=2; i<=n; ++i) q[n] = Add_pol_pol(q[n],Tensor(adams[i],q[n-i]),alt&&i%2==0); } { index i; bigint* big_n=entry2bigint(n); setshared(big_n); for (i=0; inrows; ++i) { bigint** cc= &q[n]->coef[i] ,* c= (clrshared(*cc),isshared(*cc)) ? copybigint(*cc,NULL) : *cc; *cc=divq(c,big_n); setshared(*cc); { if (c->size != 0) error("Internal error (SAtensor): remainder from %ld.\n" ,(long)n); freemem(c); } } clrshared(big_n); freemem(big_n); } } result=q[m]; { for (n=1; n<=m; ++n) freepol(adams[n]); } freearr(adams); { for (n=0; nnrows;i++) { entry* mu=chi_lambda->elm[i]; poly* prod=adams[mu[0]],*t; for (j=1; j0; ++j) { t=prod; prod=Tensor(t,adams[mu[j]]); freepol(t); } sum= Addmul_pol_pol_bin(sum,prod,mult(chi_lambda->coef[i],Classord(mu,n))); } freemem(chi_lambda); setshared(p); /* protect |p|; it coincides with |adams[1]| */ for (i=1; i<=n; ++i) { clrshared(adams[i]); freepol(adams[i]); } freearr(adams); clrshared(p); { bigint* fac_n=fac(n); setshared(fac_n); /* used repeatedly */ for (i=0; inrows; ++i) { bigint** cc= &sum->coef[i] ,* c= (clrshared(*cc),isshared(*cc)) ? copybigint(*cc,NULL) : *cc; *cc=divq(c,fac_n); setshared(*cc); if (c->size!=0) error("Internal error (plethysm).\n"); else freemem(c); } clrshared(fac_n); freemem(fac_n); } return sum; } } LiE/box/plethysm.h0000644000175000017500000000021010305606502013251 0ustar hakanhakan poly* Adams(index n,poly* p); poly* SAtensor(boolean alt,index n,poly* p); poly* Plethysm(entry* lambda,index l,index n,poly* p); LiE/box/sorting.c0000644000175000017500000001464610305606502013106 0ustar hakanhakan#include "lie.h" #define local static local entry* level_vec=NULL; local object level_vec_group=NULL; local cmpfn_tp compare; local index split_vec(entry* a,index n) { entry split_val= *a,* x=a,* end=a+n,* last_high=x; while (++xsplit_val) swap(x,++last_high); swap(a,last_high); return last_high-a; } local index split_mat(entry** m,index n,index c) { entry* split_val= *m,** x=m,** end=m+n,** last_high=x; while (++x0) swap_rows(x,++last_high); swap_rows(m,last_high); return last_high-m; } local void heapify_m(matrix* m,index i,index n) { index l,len=m->ncols; entry** a=m->elm-1; /* array~$[1:n]$ */ while ((l=i<<1)<=n) { index d= (*compare)(a[i],a[l],len)<0 ? i : l; if (l0) d=l+1; /* index of minimum among $\{i,l,l+1\}$ */ if (d==i) return; /* stop if heap condition was already satisfied */ swap_rows(&a[i],&a[d]); i=d; } } local void heapify_p(poly* p,index i,index n) { index l,len=p->ncols; entry** a=p->elm-1; bigint** coef=p->coef-1; while ((l=i<<1)<=n) { index d= (*compare)(a[i],a[l],len)<0 ? i : l; if (l0) d=l+1; /* index of minimum among $\{i,l,l+1\}$ */ if (d==i) return; /* stop if heap condition was already satisfied */ swap_terms(a,coef,i,d); i=d; } } local void build_heap_m(matrix* m) { index i,n=m->nrows; for (i=n; i>0; i--) heapify_m(m,i,n); } local void build_heap_p(poly* p) { index i,n=p->nrows; for (i=n; i>0; i--) heapify_p(p,i,n); } local void heap_sort_m(matrix* m, cmpfn_tp criterion) { index i=m->nrows; entry** a=m->elm; if (i<2) return; compare=set_ordering(criterion,m->ncols,defaultgrp); build_heap_m(m); while (swap_rows(a,&a[--i]),i>1) heapify_m(m,1,i); } local void heap_sort_p(poly* p, cmpfn_tp criterion) { index i=p->nrows; entry** a=p->elm; bigint** coef=p->coef; if (i<2) return; compare=set_ordering(criterion,p->ncols,defaultgrp); build_heap_p(p); while (swap_terms(a,coef,0,--i),i>1) heapify_p(p,1,i); } cmp_tp lex_decr(entry* v,entry * w, index len) { while (len-->0) if (*v++!=*w++) return *--v > *--w ? 1 : -1; return 0; } cmp_tp lex_incr(entry* v,entry * w, index len) { while (len-->0) if (*v++!=*w++) return *--v < *--w ? 1 : -1; return 0; } cmp_tp deg_decr(entry* v,entry * w, index len) { index i; entry delta=0; for (i=0; i0 ? 1 : -1; return lex_decr(v,w,len); /* for equal degree, revert to lexicographic */ } cmp_tp deg_incr(entry* v,entry * w, index len) { index i; entry delta=0; for (i=0; i0 ? 1 : -1; return lex_decr(v,w,len); /* for equal level, revert to lexicographic */ } cmp_tp height_incr(entry* v,entry * w, index len) { index i; entry delta=0; assert(level_vec!=NULL && Lierank(level_vec_group)==len); for (i=0; i=3) { index i=split_vec(a,n); sortrow(a,i); sortrow(&a[i+1],n-i-1); } else if (n==2 && a[0]=3) { index i=split_mat(m,n,c); sort_matrix(m,i,c); sort_matrix(&m[i+1],n-i-1,c); } else if (n==2 && (*compare)(m[0],m[1],c)<0) swap_rows(m,m+1); } void Qksortmat(matrix* m,cmpfn_tp criterion) { compare=set_ordering(criterion,m->ncols,defaultgrp); sort_matrix(m->elm,m->nrows,m->ncols); } matrix* Unique(matrix* m, cmpfn_tp criterion) { index len=m->ncols; register entry** to=m->elm,** from=to,** end=to+m->nrows; if (m->nrows<2) return m; heap_sort_m(m,criterion); while (!eqrow(*++from,*to,len)) if (++to==end-1) return m; while (++fromnrows=to+1-m->elm; return m; } poly* Reduce_pol(poly* p) { entry** expon=p->elm; bigint** coef=p->coef; index t=0,f=0,len=p->ncols; heap_sort_p(p,cmpfn); /* don't exclude cases~$<2$: we must catch $0$-polynomials */ while (++fnrows) if (coef[f]->size==0) clrshared(coef[f]); /* drop term with zero coef */ else if (eqrow(expon[f],expon[t],len)) /* equal exponents: add coef's */ { clrshared(coef[t]); clrshared(coef[f]); coef[t]=add(coef[t],coef[f]); setshared(coef[t]); } else /* now term at f replaces one at t as discriminating term */ { if (coef[t]->size) t++; else clrshared(coef[t]); /* keep if nonzero */ swap_terms(expon,coef,t,f); /* move term, preserve row separateness */ } if (p->nrows!=0) /* |p| mights have no terms at all (e.g. from |alt_dom|). */ if (coef[t]->size) t++; else clrshared(coef[t]); /* handle final term */ else *coef=copybigint(null,NULL); /* safer not to introduce aliasing */ if ((p->nrows=t)==0) /* then must keep last term; coef is cleared */ { index i; p->nrows=1; setshared(*coef); /* |*coef| was |0| but not shared */ for (i=0; incols; entry** expon; cmpfn_tp cmp=set_ordering(cmpfn,len,defaultgrp); if (!issorted(p)) { p=Reduce_pol(p); } u=p->nrows; expon=p->elm; while (u-l>1) { index m=(u+l)/2; cmp_tp c=(*cmp)(expon[m],t,len); if (c<0) u=m; else if (c>0) l=m+1; else return m; } return l1) f=mul1(f,n--); return f; } static index n_parts(index n) { index i,k,np; entry* c=mkintarray(n+1); /* coefficients */ if (n>121) error("Too many partitions to generate.\n"); for (i=0; i<=n; ++i) c[i]=1; /* initialise to ${1\over1-X}$ */ for (i=2; i<=n; ++i) for (k=i; k<=n; ++k) c[k]+=c[k-i]; /* multiply by ${1\over1-X^i}$ */ np=c[n]; freearr(c); return np; } bigint* n_tableaux(entry* lambda, index l) { index i,j,k=0; entry* h; bigint* res=copybigint(one,NULL); do if (--l<=0) return one; while (lambda[l]==0); /* find last non-zero part */ h=mkintarray(lambda[0]); for(j=0; j=0; --i) { entry li=lambda[i]-1; for(j=0; j<=li; ++j) res=mul1(res,++k); /* part of factorial */ for(j=0; j<=li; ++j) div1(res,(++h[j])+li-j); /* divide by hook lengths */ } freearr(h); return res; } bigint* Classord(entry* kappa, index l) { index prev=0,i=0,j,n=0,k,f=1; bigint* x=copybigint(one,NULL); while (i0) { for (j=0; j0 && lambda[i]>lambda[i-1]) error("Increasing entries in partition.\n"); else sum+=lambda[i]; return sum; } vector* check_tabl(vector* v) { vector* shape; entry* t=v->compon,* sh; index i,d,n=v->ncomp, max=0; for(i=0; imax) max=d; shape=mkvector(max); sh=shape->compon; for(i=0; i0 && sh[d]>sh[d-1] ) Printf("%ld at position %ld ",(long)(d+1),(long)(i+1)), error("violates tableau condition.\n"); return shape; } boolean Nextperm(entry* w, index n) { index i,j; { if (n<=1) return false; for (i=n-2; w[i]>=w[i+1]; --i) /* find last ascent |(i,i+1)| */ if (i==0) return false; /* there is none */ for (j=n-1; w[i]>=w[j]; --j) {} /* find maximal |j>i| with |w[i]=@t$\ldots$@>>w[j]>=@t$\ldots$@>>=w[n-1]| */ for (i++,j=n-1; i0 && lambda[l-1]==0) l--; for (i=l-1; i>=0 && lambda[i]==1; --i) ++avail; if (i<0) return false; /* quit if 1's only */ } k=(lambda[i++]-=1); ++avail; /* decrease the last part possible */ { while (avail>k) avail-=(lambda[i++]=k); /* distribute |avail| */ lambda[i++]=avail; /* last part may be smaller */ while (i0; --i) lambda[i]=0; /* clear |lambda| and |skew| */ for (i=0; i=0; --i) { --lambda[r=t[i]]; ++skew[r]; if (lambda[r]>c) goto found; else c=lambda[r]; } freearr(lambda); return false; /* final tableau */ found: {} } { do ++r; while (skew[r]==0 || lambda[r]==lambda[r-1]); /* find row for first changing entry */ t[i++]=r; --skew[r]; /* replace |t[i]|, update skew */ for (r=1; r<=n; ++r) while (skew[r]-->0) t[i++]=r; /* distribute remaining squares */ freearr(lambda); } return true; } matrix* Permutations(entry* v,index n) { index N=1; entry* w=mkintarray(n); copyrow(v,w,n); sortrow(w,n); { index i=0,j=n-1; while (iw[i-1]) mult=1; else N /= ++mult; } } { matrix* result=mkmatrix(N,n); index i=0; do copyrow(w,result->elm[i++],n); while (Nextperm(w,n)); freearr(w); return result; } } matrix* Partitions(index n) { matrix* result=mkmatrix(n_parts(n),n); if (n>0) { entry* lambda=mkintarray(n),** res=result->elm; index i=0,j; lambda[0]=n; for(j=1;jelm,* t=mkintarray(n); freemem(nt); { index i=0,j,k; for (j=1; j<=l; ++j) for (k=lambda[j-1]; k>0; --k) t[i++]=j; } { index i=0; do copyrow(t,res[i++],n); while(Nexttableau(t,n)); } freearr(t); return result; } vector* Trans_part(entry* lambda, index l) { index i,j=0; vector* result=mkvector(l ? lambda[0] : 0); entry* res=result->compon; for (i=l-1; i>=0; --i) while (j0; ++i) if (lambda[i]%2==0) s++; return s%2 ? -1 : 1; } void Robinson_Schensted (entry* P, entry* Q, index n, entry* sigma) { index j; for(j=n-1; j>=0; --j) { entry r=Q[j]; index i=n; while ( P[--i]!=r || (P[i]= --r)>0 ) {} sigma[j]=i+1; /* permutation values start at~|1| */ } } void Schensted_Robinson (entry* sigma, index n, entry* P, entry* Q) { index j; for(j=0;j=M) /* try parts $\geq M$ of |lambda| */ { index j; entry c=1; /* number of equal parts */ while (++ili; ++j) lambda[j-1]=lambda[j]; lambda[j-1]=li; } sum+=c*Young_char_val(lambda,mu+1,l,m-1); { while (--j>=i) lambda[j]=lambda[j-1]; lambda[j]=li+M; } } return sum; } #endif #if 0 entry Schur_char_val(entry* lambda, entry* mu, index l, index m) { index i; entry sum=0; while (l>0 && lambda[l-1]==0) --l; /* get reduced form of~|lambda| */ if (l<=1) return 1; /* trivial character */ if (l>lambda[0]) /* then better work with the transpose partition */ { vector* tr=Trans_part(lambda,l); entry ch=Schur_char_val(tr->compon,mu,lambda[0],m); freemem(tr); return Sign_part(mu,m)*ch; } { entry* lambda_prime=mkintarray(4*l) ,* sigma=lambda_prime+l,* pos=sigma+l,* nu=pos+l; /* 4 length-|l| arrays */ boolean sg=true; /* positive sign */ copyrow(lambda,lambda_prime,l); /* |lambda| might be alias of |mu|, but |lambda_prime| is not */ for (i=0; inu[i-1]) /* skip most cases */ { entry nui=nu[i]; index j=i; do nu[j]=nu[j-1]; while (--j>0 && nui>nu[j-1]); nu[j]=nui; } } sum+= sg ? Young_char_val(nu,mu,l,m) : -Young_char_val(nu,mu,l,m); { index i=0,j; do { { lambda_prime[i]-=sigma[i]; if ((j=pos[i])=0| and |sigma[j]| can move validly to |sigma[i]| */ { { if ((pos[i]=j)=0| */ } while (true); } } while (true); freearr(lambda_prime); } return sum; } #endif #if 0 matrix* Schur_char(entry* lambda, index l) { index i,n=check_part(lambda,l); entry np=n_parts(n); matrix* result=mkmatrix(np,n+1); entry** res=result->elm; res[0][0]=n; for (i=1; i=0; --r) { while (c1; --r) /* try hooks of size |r| */ if (candidate[r]) { recurse: /* recursive starting point */ { for (j=1; j0; ) if (edge[j++]==vert) s+=lambda_prime[--r]=c; else ++c; /* build |lambda_prime| from edges */ for (j=0; j0) goto resume; { freearr(edge); freearr(mu); } } return wt_collect(); } bigint* MN_char_val(entry* lambda, entry* mu, index l, index m) { bigint* value=null; index n=check_part(lambda,l),m2; if (n==0) return one; while (lambda[l-1]==0) --l; while (mu[m-1]==0) --m; for (m2=m; m2>0 && mu[m2-1]==1; --m2) {} /* number of parts $\mu_i\geq2$ */ { entry* save=mkintarray(2*n),* lambda_prime=save+n; int i, j, d=lambda[0]+l, k=0; /* sum of leg lengths */ boolean* edge=alloc_array(boolean,2*d); enum {hor, vert}; { int r=l-1,c=0; /* current column number */ for (j=0; r>=0; --r) { while (c0; ) if (edge[j++]==vert) s+=lambda_prime[--r]=c; else ++c; /* build |lambda_prime| from edges */ value= k%2==0 ? add(value,n_tableaux(lambda_prime,l)) : sub(value,n_tableaux(lambda_prime,l)) ; } if (i>0) goto resume; } freearr(edge); freearr(save); } return value; } LiE/box/symg.h0000644000175000017500000000136510305606502012377 0ustar hakanhakan bigint* fac(index n); bigint* n_tableaux(entry* lambda, index l); bigint* Classord(entry* kappa, index l); index check_part(entry* lambda, index l); vector* check_tabl(vector* v); boolean Nextperm(entry* w, index n); boolean Nextpart(entry* lambda, index l); boolean Nexttableau(entry* t, index n); matrix* Permutations(entry* v,index n); matrix* Partitions(index n); matrix* Tableaux(entry* lambda, index l); vector* Trans_part(entry* lambda, index l); entry Sign_part(entry* lambda, index l); void Robinson_Schensted (entry* P, entry* Q, index n, entry* sigma); void Schensted_Robinson (entry* sigma, index n, entry* P, entry* Q); poly* MN_char(entry* lambda, index l); bigint* MN_char_val(entry* lambda, entry* mu, index l, index m); LiE/box/tensor.c0000644000175000017500000001032710305606502012723 0ustar hakanhakan#include "lie.h" #define local static local simpgrp* the_g; local entry* lamrho,* cur_expon; local bigint* cur_mult; local entry* goal; local bigint* totmul; local void add_tensor_wt(entry* mu) { index k,r=the_g->lierank; boolean neg; addrow(lamrho,mu,cur_expon,r); /* |cur_expon=mu+lambda+rho| */ neg=simp_make_dominant(cur_expon,the_g)%2!=0; /* apply |alt_dom| action */ for (k=0; klierank; boolean neg; addrow(lamrho,mu,cur_expon,r); /* |cur_expon=mu+lambda+rho| */ neg=simp_make_dominant(cur_expon,the_g)%2!=0; /* apply |alt_dom| action */ if (!eqrow(cur_expon,goal,r)) return; /* quit unless |cur_expon==goal| */ totmul= neg ? sub(totmul,cur_mult) : add(totmul,cur_mult); /* incorporate in |totmul| */ } local poly* simp_tensor_irr(entry* lambda,entry* mu,entry* nu,simpgrp* g) { poly* result; index i,r=g->lierank; the_g=g; testdom(lambda,(object)g); testdom(mu,(object)g); cur_expon=mkintarray(r); if (nu!=NULL) { goal=mkintarray(r); copyrow(nu,goal,r); /* |goal=nu| */ for (i=0; inrows; ++i) /* traverse dominant weights in character */ { cur_mult=domchar->coef[i]; /* |cur_mult| is alias for the relevant multiplicity (shared) */ Weylloop(nu ? add_goal_wt : add_tensor_wt,domchar->elm[i]); } Weylloopexit(); freemem(domchar); } freearr(cur_expon); freearr(lamrho); if (nu==NULL) return wt_collect(); else { freearr(goal); result=mkpoly(1,0); result->coef[0]=totmul; setshared(totmul); return result; } } local poly* tensor_irr(entry* lambda,entry* mu,entry* nu) { if (type_of(grp)==SIMPGRP) return simp_tensor_irr(lambda,mu,nu,&grp->s); if (simpgroup(grp)) return simp_tensor_irr(lambda,mu,nu,Liecomp(grp,0)); { poly* result; index s=Ssrank(grp),td=grp->g.toraldim; /* size of toral part */ { lambda+=s; mu+=s; /* move to start of toral part */ if (nu==NULL) { result=mkpoly(1,td); addrow(lambda,mu,*result->elm,td); *result->coef=one; } else { entry* lm=mkintarray(td); boolean correct_weight; addrow(lambda,mu,lm,td); nu+=s; /* move to toral part of weight */ correct_weight=eqrow(lm,nu,td); freearr(lm); if (correct_weight) result=poly_one(0); else return poly_null(0); } } { index i; for (i=grp->g.ncomp-1; i>=0; --i) { simpgrp* g=Liecomp(grp,i); index d=g->lierank; lambda-=d; mu-=d; if (nu!=NULL) nu-=d; /* move back to previous component */ result= Disjunct_mul_pol_pol(simp_tensor_irr(lambda,mu,nu,g),result); } } return result; } } poly* Tensor(poly* p,poly* q) { index i,j; poly* ans=poly_null(Lierank(grp)); for (i=0; inrows; ++i) for (j=0; jnrows; ++j) ans=Addmul_pol_pol_bin(ans,tensor_irr(p->elm[i],q->elm[j],NULL) ,mult(p->coef[i],q->coef[j])); return ans; } bigint* Tensor_coef(poly* p, poly* q,vector* nu) { index i,j; bigint* ans=null; for (i=0; inrows; ++i) for (j=0; jnrows; ++j) { poly* res=tensor_irr(p->elm[i],q->elm[j],nu->compon); ans=add(ans,mult(res->coef[0],mult(p->coef[i],q->coef[j]))); freepol(res); } return ans; } poly* Ptensor(index n, poly* p) { poly* x,* y; if (n==0) return poly_one(Lierank(grp)); if (n==1) return p; x=p; setshared(p); /* protect |p| against |freepol| */ do { y=Tensor(x,p); freepol(x); x=y; } while (--n>1); clrshared(p); /* now |p| needs no more protection */ return x; } LiE/box/tensor.h0000644000175000017500000000017310305606502012726 0ustar hakanhakan poly* Tensor(poly* p, poly* q); bigint* Tensor_coef(poly* p, poly* q,vector* lambda); poly* Ptensor(index p, poly* m); LiE/box/weylloop.c0000644000175000017500000002543110305606502013265 0ustar hakanhakan#include "lie.h" #define local static #define is_odd(x) ((x&1)!=0) #define set_vec(v,s) \ { char* p=s; int i=0; do v->compon[i++]=*p++-'0'; while (*p!='\0'); \ v->ncomp=i; \ } local simpgrp* the_g; /* the simple group in question */ local index rnk; /* Lie rank of full group */ local index eps_dim; /* dimension of $\eps$-space */ local index perm_size; /* number of entries to be permuted */ local char subtype; /* type of classical subgroup used for suborbits */ typedef void (*trans)(entry const* from, entry* to); local trans to_e, from_e; local boolean alternate; local index cox_order, X_order; local matrix* cox,* X_elt[9]; /* matrices of size |[eps_dim]|{}|[eps_dim]| */ local matrix* suborbit_reps; /* size |[cox_order*X_order]|{}|[eps_dim]| */ local vector* temp1,* temp2; local void w2eAn(entry const* w,entry* e) { index i=rnk; entry sum=0; while (e[i]=sum,--i>=0) sum+=w[i]; } local void e2wAn(entry const* e,entry* w) { index i; for (i=0; i=0) sum+=2*w[i]; } local void e2wBn(entry const* e,entry* w) { index i; for (i=0; i=0) sum+=w[i]; } local void e2wCn(entry const* e,entry* w) { index i; for (i=0; i=0) sum+=2*w[i]; } local void e2wDn(entry const* e,entry* w) { index i; for (i=0; i=2; --i) {sum+=e[u-i]; w[i]=(e[u-i]-e[u-i+1])/2;} w[1]=w[2]+e[u-1]; w[0]=(e[u-1]-sum)/4; } local void w2eE7(entry const* w,entry* e) { index i; entry sum=e[7]=0; for (i=6; i>=2; --i) e[i]=sum+=w[i]; e[1]=sum+w[0]; e[0]=e[6]+e[5]+e[4]-e[3]-e[2]-e[1]-2*w[1]; } local void e2wE7(entry const* e,entry* w) { index i; w[0]=e[1]-e[2]; for(i=2; i<7; i++) w[i]=e[i]-e[i+1]; w[1]=(e[7]+e[6]+e[5]+e[4]-e[3]-e[2]-e[1]-e[0])/2; } local void w2eF4(entry const* w,entry* e) { e[1]=(e[2]=(e[3]=w[2])+2*w[1])+2*w[0]; e[0]=-2*w[3]-e[1]-e[2]-e[3]; } local void e2wF4(entry const* e,entry* w) { w[2]=e[3]; w[1]=(e[2]-e[3])/2; w[0]=(e[1]-e[2])/2; w[3]=-(e[0]+e[1]+e[2]+e[3])/2; } local void w2eG2(entry const* w,entry* e) { e[2]=0; e[0]=-w[0]-(e[1]=w[1]); } local void e2wG2(entry const* e,entry* w) { w[0]=e[2]-(w[1]=e[1]-e[2])-e[0]; } #if 0 local void r2eAn (entry const* r,entry* e) { index i; e[0]=r[0]; for (i=1;i1) e[u-i]=2*(r[i]-r[i+1])-a; e[u-1]=2*(r[1]-r[2])+a; e[u-2]+=2*r[1]; } local void e2rE68 (entry const* e,entry* r) { index i,u=perm_size; entry sum=0,a=e[rnk==6 ? 5 : 0]; r[0]=-a; for (i=rnk-1; i>2; --i) r[i]=(sum+=e[u-i]-a)/2; r[1]=(sum+e[u-2]+e[u-1])/4; r[2]=r[1]-(a+e[u-1])/2; } local void r2eE7 (entry const* r,entry* e) { entry a=r[1]; e[0]=-a; e[1]=2*r[0]-a; e[2]=2*(r[2]-r[0])-a; e[3]=2*(r[3]-r[2])-a; e[4]=a+2*(r[4]-r[3]); e[5]=a+2*(r[5]-r[4]); e[6]=a+2*(r[6]-r[5]); e[7]=a-2*r[6]; } local void e2rE7 (entry const* e,entry* r) { entry a=e[0]; r[1]=-a; r[3]=(r[2]=(r[0]=(e[1]-a)/2)+(e[2]-a)/2)+(e[3]-a)/2; r[6]=(r[5]=(r[4]=r[3]+(e[4]+a)/2)+(e[5]+a)/2)+(e[6]+a)/2; } #endif #if 0 local void r2eF4 (entry const* r,entry* e) { e[0]=-r[3]; e[1]=2*r[0]-r[3]; e[2]=2*(r[1]-r[0])-r[3]; e[3]=2*(r[2]-r[1])-r[3]; } local void e2rF4 (entry const* e,entry* r) { r[3]=-e[0]; r[2]=(r[1]=(r[0]=(e[1]-e[0])/2)+(e[2]-e[0])/2)+(e[3]-e[0])/2; } local void r2eG2 (entry const* r,entry* e) { e[1]=r[0]+(e[0]=-r[1]); e[2]=-e[0]-e[1]; } local void e2rG2 (entry const* e,entry* r) { r[0]=(r[1]=-e[0])+e[1]; } #endif local void normalform(entry* w) { index i, parity=0; if (subtype=='A') { { index i=0, j=perm_size-1; sortrow(w,perm_size); while (i=0; --i) w[i]-=w[0]; } else { for(i=0; ielm; /* next row of |suborbit_reps| */ entry* cur=temp1->compon,* alt=temp2->compon; /* will be swapped repeatedly */ copyrow(v,cur,rnk); /* make working copy of |v|, which will be modified */ do /* effectively |for (k=0; kelm,alt,rnk,rnk); /* |alt=cur*X_elt[i]| */ (*to_e)(alt,*p); normalform(*p++); /* store converted vector after normalising it */ } if (++k>=cox_order) break; /* note that if |cox_order==1|, |cox| is never used */ { entry* t=cur; mulvecmatelm(cur,cox->elm,alt,rnk,rnk); cur=alt; alt=t; } } while(true); suborbit_reps->nrows=cox_order*X_order; Unique(suborbit_reps,cmpfn); /* remove duplicate suborbits */ } void Weylloopinit(simpgrp* g) { the_g=g; rnk=g->lierank; /* save values used by other functions */ { int i; static trans tab [8][2]= { { w2eAn, e2wAn } , { w2eBn, e2wBn } , { w2eCn, e2wCn } , { w2eDn, e2wDn } , { w2eE68,e2wE68 } , { w2eF4, e2wF4 } , { w2eG2, e2wG2 } , { w2eE7, e2wE7 } }; if (the_g->lietype=='E' && rnk==7) i=7; else #if 'G'-'A'==6 i=the_g->lietype-'A'; #else { static char s[]="ABCDEFG"; i= (int)(strchr(s,the_g->lietype)-s); } #endif subtype= "ABCDDBAA"[i]; eps_dim= subtype=='A' ? rnk+1 : rnk; perm_size = the_g->lietype=='E' && rnk==6 ? eps_dim-1 : eps_dim; to_e=tab[i][0]; from_e=tab[i][1]; } temp1=mkvector(eps_dim); temp2=mkvector(eps_dim); /* scratch vectors */ X_elt[0]=mat_id(rnk); if (strchr("ABCD",g->lietype)!=NULL) { cox_order=X_order=1; cox=NULL; } else { matrix* tmpmat; index i; vector* coxw=mkvector(rnk); /* some Coxeter word */ if (g->lietype=='E') { vector* gen=mkvector(15); /* large enough for largest use */ if (rnk==6) { X_order=3; cox_order=12; set_vec(coxw,"625431") cox=simp_Weylmat(coxw,the_g); set_vec(gen,"2431") X_elt[1]=simp_Weylmat(gen,the_g); set_vec(gen,"1452431") X_elt[2]=simp_Weylmat(gen,the_g); } else if (rnk==7) { X_order=4; cox_order=18; set_vec(coxw,"1234567") cox=simp_Weylmat(coxw,the_g); set_vec(gen,"76543215342") X_elt[1]=simp_Weylmat(gen,the_g); X_elt[2]=Matmult(X_elt[1],X_elt[1]); /* $x^2$ */ X_elt[3]=Matmult(tmpmat=Matmult(X_elt[2],X_elt[2]),X_elt[1]); /* $x^5$ */ freemem(tmpmat); } else { X_order=9; cox_order=15; set_vec(coxw,"75328641") cox=simp_Weylmat(coxw,the_g); set_vec(gen,"743245613452431") X_elt[1]=simp_Weylmat(gen,the_g); /* $x_1$ */ tmpmat=Matmult(X_elt[1],X_elt[1]); X_elt[2]=Matmult(tmpmat,X_elt[1]); /* $x_1^3$ */ X_elt[3]=Matmult(tmpmat,tmpmat); /* $x_1^4$ */ freemem(tmpmat); set_vec(gen,"867563452431") X_elt[4]=simp_Weylmat(gen,the_g); /* $x_2$ */ for (i=5; i<9; ++i) X_elt[i]=Matmult(X_elt[4],X_elt[i-1]); /* $x_2^2$, $x_2^3$, $x_2^4$, $x_2^5$ */ } freemem(gen); } else /* type |F4| or |G2| */ { if (g->lietype=='F') { cox_order=3; set_vec(coxw,"1234") } else { cox_order=2; set_vec(coxw,"12") } cox=simp_Weylmat(coxw,the_g); X_order=1; } freemem(coxw); } suborbit_reps=mkmatrix(cox_order*X_order, eps_dim); } void Weylloopexit(void) { freemem(temp1); freemem(temp2); freemem(suborbit_reps); { index i; for (i=0; icompon; index k,* inx=NULL; /* indices of non-zero entries in |w| */ tabulate_suborbits(v); if (subtype!='A') inx=alloc_array(index,perm_size+1); /* one extra for the terminating |-1| */ for (k=0; knrows; ++k) /* traverse suborbit representatives */ { entry* w=suborbit_reps->elm[k]; /* it is safe to modify this vector */ if (subtype=='A') do { (*from_e)(w,tmp); (*action)(tmp); } while (Nextperm(w,perm_size)); else { alternate= subtype=='D' && w[0]!=0; /* whether type $D_n$ and no 0's */ do /* traverse permutations */ { unsigned long signcount=0; { index i,j=0; { for (i=0; i=0 && is_odd(bits)) { bits>>=1; ++i; } if (inx[i]<0) { if (--i>=0) w[inx[i]]*=-1; break;} /* done; restore |w| and quit */ w[inx[i]]*=-1; /* otherwise change this one sign */ } } while(true); { boolean minus= alternate && w[0]<0; /* if this holds, |w[0]| is unique negative entry */ if (minus) w[0]*=-1; if (!Nextperm(w,perm_size)) break; if (minus) w[0]*=-1; } } while(true); } } if (inx!=NULL) freearr(inx); } LiE/box/weylloop.h0000644000175000017500000000015410305606502013265 0ustar hakanhakan void Weylloopinit(simpgrp* g); void Weylloop(void (*action)(entry*),entry* v); void Weylloopexit(void); LiE/box/weylorbit.c0000644000175000017500000001453110305606502013432 0ustar hakanhakan#include "lie.h" #define local static #define NDEBUG local simpgrp* the_g; /* the simple group in question */ local index rnk,n_pos_roots; /* Lie rank, number of positive roots */ local void (* the_Weyl_loop) (void(*)(entry*),entry*); /* the function doing the Weyl loop */ local entry* word; /* stack of reflection indices, describing how we got here */ local index depth; /* index into |word|, current depth of word */ local entry* max_neighbour; /* last larger index of neighbour in diagram */ local entry* pred_coef; void generic_Weyl_loop(void(* action )(entry*),entry* mu); void A_Weyl_loop(void(* action )(entry*),entry* mu); void C_Weyl_loop(void(* action )(entry*),entry* mu); void ABF_Weyl_loop(void(* action )(entry*),entry* mu); void CG_Weyl_loop(void(* action )(entry*),entry* mu); void Weylloopinit(simpgrp* g) { index i; the_g=g; rnk=g->lierank; n_pos_roots=simp_numproots(g); /* save values used by other functions */ the_Weyl_loop= strchr("ABF",g->lietype)!=NULL ? ABF_Weyl_loop : generic_Weyl_loop; if (g->lietype=='A') the_Weyl_loop= A_Weyl_loop; word= mkintarray(n_pos_roots); max_neighbour= mkintarray(2*rnk); pred_coef=&max_neighbour[rnk]; for (i=0; ilietype=='E') { max_neighbour[0]=2; max_neighbour[1]=3; } else if (g->lietype=='D') { max_neighbour[i-1]=0; max_neighbour[i-2]=i; } pred_coef[i]= g->lietype=='C' ? 2 : g->lietype=='G' ? 3 : 1; /* last Cartan coefficient with predecessor is not |1| in types $C,G$ */ } void Weylloop(void(* action )(entry*),entry* mu) { (*the_Weyl_loop)(action,mu); } void Weylloopexit(void) { freearr(word); freearr(max_neighbour); } void generic_Weyl_loop(void(* action )(entry*),entry* mu) { index j=rnk; depth=0; simp_make_dominant(mu,the_g); do { if (--j>=0) do { { if (mu[j]<=0) break; /* child must be further from dominant chamber */ if (depth>0) /* at level |0| every |s_j| not stabilising $\mu$ is good */ { index i=word[depth-1]; /* index of the reflection that brought us here */ if (j>i) /* every |s_j| with $jlietype=='E' && j==i+1 && i<2) break; if (mu[i]+pred_coef[j]*mu[j]<0) break; if (j==i+2 && (the_g->lietype=='E' && j==3 ? mu[2]+mu[3]<0 : mu[j-1]<0 ) ) break; } } } assert(depth=0) while (mu[j]>0 && (depth==0 || j<=word[depth-1] || mu[j-1]+mu[j]>=0)) { word[depth++]=j; /* push |j| on stack */ simp_w_refl(mu,j,the_g); /* and move to weight at child node */ if (j==rnk-1) break; /* no followers, start with |j=j-1| */ ++j; /* otherwise, start considering next node */ } action(mu); if (--depth<0) break; /* if nothing left on stack, we are done */ j=word[depth]; /* otherwise pop |j| from stack */ simp_w_refl(mu,j,the_g); /* and find weight at parent node */ } while(1); } void A_Weyl_loop(void(* action )(entry*),entry* mu) { index j=rnk-1; depth=0; simp_make_dominant(mu,the_g); goto enter; do { entry muj=mu[j=word[depth]]; mu[j]= -muj; if (j0) { mu[--j]+=muj; enter: do while (mu[j]>0 && (depth==0 || j<=word[depth-1] || mu[j-1]+mu[j]>=0)) { entry muj=mu[j]; word[depth++]=j; /* push |j| on stack */ mu[j]= -muj; if (j>0) mu[j-1]+=muj; if (j==rnk-1) break; /* no followers, consider |j=j-1| next */ mu[++j]+=muj; /* otherwise complete reflection, and consider |j+1| next */ } while (--j>=0); } action(mu); } while(--depth>=0); /* if nothing left on stack, we are done */ } void C_Weyl_loop(void(* action )(entry*),entry* mu) { index j=rnk; depth=0; simp_make_dominant(mu,the_g); do { while (--j>=0) while (mu[j]>0 && (depth==0 || j<=word[depth-1] || mu[j-1]+(j!=rnk-1 ? mu[j] : 2*mu[j])>=0)) { entry muj=mu[j]; word[depth++]=j; /* push |j| on stack */ { if (j>0) mu[j-1]+=muj; } mu[j]= -muj; if (j==rnk-1) { mu[j-1]+=muj; break; } /* add again for long root */ mu[++j]+=muj; /* otherwise complete reflection, consider |j+1| next */ } action(mu); if (--depth<0) break; /* if nothing left on stack, we are done */ j=word[depth]; /* otherwise pop |j| from stack */ { entry muj=mu[j]; mu[j]= -muj; if (j==rnk-1) mu[j-1]+=2*muj; else { mu[j+1]+=muj; if (j>0) mu[j-1]+=muj; } } } while(1); } void CG_Weyl_loop(void(* action )(entry*),entry* mu) { index j=rnk; depth=0; simp_make_dominant(mu,the_g); do { if (--j>=0) { do { { if (mu[j]<=0) break; /* child must be further from dominant chamber */ if (depth>0) /* at level |0| every |s_j| not stabilising $\mu$ is good */ { index i=word[depth-1]; /* index of the reflection that brought us here */ if (j>i && mu[i]+pred_coef[j]*mu[j]<0) break; } } assert(depthlierank; entry wi=w[i]; if (wi==0) return; /* weight is on reflection hyperplane */ { if (i>0) w[i-1]+=wi; } w[i]= -wi; { if (ilietype) { case 'B': if (i==r-2) w[i+1]+=wi; break; case 'C': if (i==r-1) w[i-1]+=wi; break; case 'D': if (i>=r-3) if (i==r-1) { w[i-2]+=wi; w[i-1]-=wi; } else if (i==r-2) w[i+1]-=wi; else w[i+2]+=wi; break; case 'E': if (i<4) { if (i<2) { w[i+1]-=wi; w[i+2]+=wi; } else w[i-2]+=wi; if (i==1 || i==2) w[i-1]-=wi; } break; case 'F': if (i==1) w[2]+=wi; break; case 'G': if (i==1) w[0]+=2*wi; } } local void simp_rt_refl (entry* w,index i,simpgrp* g) { index r=g->lierank; entry c= -w[i]+(i>0?w[i-1]:0)+(ilietype) { case 'B': if (i==r-1) c+=w[i-1]; /* long root neighbour of short root contributes twice */ break; case 'C': if (i==r-2) c+=w[i+1]; /* idem */ break; case 'D': if (i>=r-3) /* correct for different adjacencies at end of diagram */ if (i==r-1) c+=w[i-2]-w[i-1]; /* attach node $r$ to $r-2$ rather than to $r-1$ */ else if (i==r-2) c-=w[i+1]; /* detach $r-1$ from $r$ */ else c+=w[i+2]; /* and attach $r-2$ to $r$ */ break; case 'E': if (i<4) /* similar adjustments here */ { if (i<2) c+=w[i+2]-w[i+1]; /* nodes 1,2 neighbour 3,4 respectively rather than 2,3 */ else c+=w[i-2]; /* for nodes 3,4, add neighbour 1,2, respectively */ if (i==1 || i==2) c-=w[i-1]; /* and for nodes 2,3, remove neighbour 1,2, respectively */ } break; case 'F': if (i==2) c+=w[1]; /* like types $B_n$, $C_n$ */ break; case 'G': if (i==0) c+=2*w[1]; /* now long root contributes 3 times */ } w[i]=c; } void w_refl(entry* lambda, index wi) { if (type_of(grp)==SIMPGRP) simp_w_refl(lambda,wi,&grp->s); else if (simpgroup(grp)) simp_w_refl(lambda,wi,Liecomp(grp,0)); else { index i,d,offset=0; for (i=0; wi>=(d=Liecomp(grp,i)->lierank); ++i) { offset+=d; wi-=d; } simp_w_refl(lambda+offset,wi,Liecomp(grp,i)); } } void Waction(entry* lambda, vector* word) { index i; entry* w=word->compon; for (i=0; incomp; ++i) if (w[i]!=0) w_refl(lambda,w[i]-1); } void Wrtaction(entry* alpha, vector* word) { index i; entry* w=word->compon; for (i=0; incomp; ++i) if(w[i]!=0) { index wi=w[i]-1; if (type_of(grp)==SIMPGRP) simp_rt_refl(alpha,wi,&grp->s); else if (simpgroup(grp)) simp_rt_refl(alpha,wi,Liecomp(grp,0)); else { index j,d,offset=0; for (j=0; wi>=(d=Liecomp(grp,j)->lierank); ++j) { offset+=d; wi-=d; } simp_rt_refl(alpha+offset,wi,Liecomp(grp,j)); } } } matrix* simp_Weylmat(vector* word, simpgrp* g) { index i,j,r=g->lierank; matrix* res=mkmatrix(r,r); entry** m=res->elm,* w=word->compon; for (i=0; incomp; ++j) if(w[j]!=0) simp_w_refl(m[i],w[j]-1,g); } return res; } matrix* Weyl_mat(vector* word) { index i,j,r=Lierank(grp); matrix* res=mkmatrix(r,r); entry** m=res->elm; for (i=0; ielm; for (i=0; ilierank; bigint* result=num; i=r; while (i>1) result=mul1(result,i--); switch (g->lietype) { case 'A': result=mul1(result,r+1); break; case 'B': case 'C': for (i=0; is); for (i=0; ig.ncomp; ++i) result = simp_worder(result,Liecomp(grp,i)); return result; } bigint* sub_Worder(vector* v) { index i,j,s=Ssrank(grp), n=v->ncomp; matrix* roots=mkmatrix(n,s); entry** m=roots->elm; group* h; bigint* result; if (n==0) { freemem(roots); return one; } for (i=0; icompon[i]-1; for (j=0; jlierank; for (i=0; icompon[nz++]=i+1; grp=(object)g; result=sub_Worder(I); grp=sav_grp; freemem(I); return result; } bigint* simp_worbitsize(entry* w, simpgrp* g) /* |w| is assumed to be dominant */ { return quotient(simp_worder(copybigint(one,NULL),g),simp_stabsize(w,g)); } bigint* Orbitsize(entry* w) { index i,d,s=Ssrank(grp); entry* x=mkintarray(s),* y=x; bigint* result=one; copyrow(w,x,s); make_dominant(x); if (type_of(grp)==SIMPGRP) return simp_worbitsize(x,&grp->s); for (i=0; ig.ncomp; ++i,y+=d) { simpgrp* g=Liecomp(grp,i); d=g->lierank; result=mult(result,simp_worbitsize(y,g)); } freearr(x); return result; } matrix* Weyl_orbit(entry* v, matrix** orbit_graph) { index i,j,k,r=Lierank(grp),s=Ssrank(grp); matrix* result; entry** m; index level_start=0, level_end=1, cur=1; { entry* lambda=mkintarray(r); copyrow(v,lambda,r); make_dominant(lambda); result=mkmatrix(bigint2entry(Orbitsize(lambda)),r); copyrow(lambda,result->elm[0],r); freearr(lambda); if (orbit_graph!=NULL) *orbit_graph=mkmatrix(result->nrows,s); } m=result->elm; while (level_start0) /* only strictly cross walls, and from dominant side */ { w_refl(m[k],i); for (j=level_end; jelm[k][i]=j; (*orbit_graph)->elm[j][i]=k; } if (j==cur) { assert(curnrows); copyrow(m[k],m[cur++],r); } w_refl(m[k],i); } else if (m[k][i]==0 && orbit_graph!=NULL) (*orbit_graph)->elm[k][i]=k; level_start=level_end; level_end=cur; } return result; } matrix* Weyl_root_orbit(entry* v) { index i,j,r=Lierank(grp),s=Ssrank(grp); entry* x=mkintarray(r); matrix* orbit, *result; entry** m; index dc=Detcartan(); mulvecmatelm(v,Cartan()->elm,x,s,r); orbit=Weyl_orbit(x,NULL); result=mkmatrix(orbit->nrows,s); m=result->elm; mulmatmatelm(orbit->elm,Icartan()->elm,m,orbit->nrows,s,s); freemem(orbit); for (i=0; inrows; ++i) for (j=0; jncols; poly* result; entry** res; p=copypoly(p); for (i=0; inrows; ++i) make_dominant(p->elm[i]); Reduce_pol(p); for (i=0; inrows; ++i) if ((l += bigint2entry(Orbitsize(p->elm[i])))<0) error ("That's too large an orbit"); result=mkpoly(l,p->ncols); res=result->elm; for (i=0; inrows; ++i) { index j; matrix* orbit=Weyl_orbit(p->elm[i],NULL); entry** x=orbit->elm; for (j=0; jnrows; ++j) { result->coef[k]=p->coef[i]; setshared(p->coef[i]); copyrow(*x++,res[k++],r); } freemem(orbit); } assert(k==result->nrows); return result; /* not sorted, but rows are unique */ } poly* alt_Wsum(poly* p) { index i,k=0,r=p->ncols; poly* result; entry** res,*rho=mkintarray(r); p=Alt_dom(p); for (i=0; inrows; ++i) add_xrow_to(p->elm[i],1,rho,r); result=mkpoly(p->nrows*bigint2entry(Worder(grp)),r); res=result->elm; for (i=0; inrows; ++i) { index j,l; matrix* orbit=Weyl_orbit(p->elm[i],NULL); entry** x=orbit->elm; bigint* c=p->coef[i],* min_c=sub(null,c); for (j=0; jnrows; ++j) { subrow(*x,rho,res[k],r); l=make_dominant(*x++)%2; result->coef[k]= l ? min_c : c; setshared(result->coef[k]); ++k; } freemem(orbit); } freearr(rho); assert(k==result->nrows); return result; /* not sorted, but rows are unique */ } LiE/gettype.c0000644000175000017500000001577510305606502012316 0ustar hakanhakan#include "lie.h" #define RETURNSTACK_LEN 200 #define VAR_LEN 1000 static struct { strtype name; objtype type; } type_stack[VAR_LEN]; static objtype return_type[RETURNSTACK_LEN]; static int return_pt, var_pt; static objtype last_type(symblst s) { if (s==NULL) return VOID; while (s->next!=NULL) s=s->next; return s->type; } static void add_var(strtype name,objtype type) { if (var_pt>=VAR_LEN) error("Number of variables (%ld) exceeded.\n",(long)VAR_LEN); type_stack[var_pt].name=name; type_stack[var_pt++].type=type; } static void push_type(symblst list) { for ( ; list!=NULL; list=list->next) add_var(list->formal,list->type); } static objtype type_var(strtype name) { int i=var_pt-1; for (i=var_pt-1; i>=0; --i) if (type_stack[i].name==name) return type_stack[i].type; { symblst foundsym=srchsym(topsym,name,NULL); if (foundsym==NULL || foundsym->class!=VALUE) return ERROR; return foundsym->type; } } static void check_function_args(symblst sym,symblst foundsym) { symblst f,s; for (f=foundsym->arglst, s=sym->arglst; f!=NULL && s!=NULL; f=f->next,s=s->next) if (isfuntype(f) && s->class != BLOCK) error("%s is not a user defined function. \n" ,name_tab[s->a.label->name]); } static void check_var_type(strtype name,objtype type) { int i; objtype old_type; if (type==UNKNOWN) return; /* assume all is well in this case */ for (i=var_pt-1; i>=0; --i) if (type_stack[i].name==name) { old_type=type_stack[i].type; goto found; } { symblst foundsym=srchsym(topsym,name,NULL); add_var(name,type); /* add local variable, whether or not found */ if (foundsym==NULL) return; old_type=foundsym->type; } found: if (block_depth==0) { if (i>=0) type_stack[i].type=type; } /* change type */ else if (!eq_types(type,old_type)) error("Illegal type change for %s: %s -> %s,\n" ,name_tab[name],code_obj_type(old_type),code_obj_type(type)); } extern fobject seqfun; void init_loop_gettype(void) { var_pt=return_pt=0; } objtype eval_type(symblst s) { symblst t=s->arglst; strtype name=s->a.label->name; labeltp label0=label; label=s->a.label; for (; t!=NULL; t=t->next) { if (t->type==UNKNOWN) { if (eval_type(t)==UNKNOWN && name_tab[name][0]!='.') return UNKNOWN; if (t->a.label!=NULL && t->a.label!=label_null && t->a.label->name==return_name) { if (return_pt==RETURNSTACK_LEN) error("Too many happy returns:\n"); return_type[return_pt++]=t->type; } } } label=label0; /* restore |label| after handling arguments */ { symblst foundsym; strtype name=s->a.label->name; if (s->type!=UNKNOWN) return s->type; if (name==0) error("System error: eval_type0: no_name.\n"); if (name==seq_name) { s->class=MAP; s->data.f=seqfun; return s->type=last_type(s->arglst); } if (s->class==BLOCK) { int var_pt0=var_pt; ++block_depth; push_type(s->arglst); s->type=eval_type(s->data.expr); var_pt=var_pt0; --block_depth; return s->type; } { objtype type; if (s->arglst==NULL && (type=type_var(name))!=ERROR) { s->class=DUMMY; return s->type=type; } } { if ((foundsym=srchsym(symbol_tab[name],name,s->arglst))==NULL) foundsym=srchsym(topsym, name, s->arglst); if (foundsym==NULL) error_not_foundsym(s); check_function_args(s,foundsym); assignsym(s,foundsym); /* set |s->class| and |s->type| */ if (s->class==OPERATOR) s->data.expr=foundsym; /* save binding found */ } if (name==assign_name || name==assign_loc_name) { symblst lhs=s->arglst, rhs=lhs->next; strtype varname=lhs->a.label->name; /* name of left hand side */ if (rhs->type==VOID) error("You cannot assign a %s value.\n", code_obj_type(VOID)); if (name==assign_loc_name) { if (block_depth==0) error ("'loc %s= .. ' can only be used inside functions/blocks.\n" ,name_tab[varname]); add_var(varname, rhs->type); } else check_var_type(varname,rhs->type); return s->type=VOID; } if (name==if_name) { symblst then_part=s->arglst->next, else_part=then_part->next; if (else_part==NULL) return s->type=VOID; if (!eq_types(then_part->type,else_part->type) && then_part->type!=UNKNOWN && else_part->type!=UNKNOWN) error("Type mismatch between branches of if-clause: %s and %s.\n" ,code_obj_type(then_part->type), code_obj_type(else_part->type)); return s->type= then_part->type!=UNKNOWN ? then_part->type : else_part->type; } if (s->type==ARGTYPE) { if ((s->type=last_type(s->arglst))!=UNKNOWN) return s->type; } if (s->class==FUNCTION) { int var_pt0=var_pt, return_pt0=return_pt; strtype fun_name_old=fun_name; { fun_name=foundsym->a.name; ++block_depth; assignnames(s, foundsym->arglst); push_type(s->arglst); } { s->data.expr=load_function_body(foundsym->data.func); foundsym->class=FUNCTION_COPIED; s->type= eval_type(s->data.expr); foundsym->class=FUNCTION; s->class=BLOCK; } { int i; for (i=return_pt0; itype) && return_type[i]!=UNKNOWN && s->type!=UNKNOWN) break; else if (s->type==UNKNOWN) s->type=return_type[i]; if (itype)); } if (s->type==UNKNOWN) error("The result of function %s has indeterminate type.\n" ,name_tab[name]); } { var_pt=var_pt0; return_pt=return_pt0; fun_name=fun_name_old; --block_depth; } return s->type; } return s->type; /* if |s->class==FUNCTION_COPIED|, this is |UNKNOWN| */ } } LiE/gettype.h0000644000175000017500000000010010305606502012273 0ustar hakanhakan objtype eval_type(symblst s); void init_loop_gettype(void); LiE/getvalue.c0000644000175000017500000001323010305606502012431 0ustar hakanhakan#include "lie.h" extern long chunks; static void clear_arguments(symblst argsym); static void evalbl_value(symblst topnode) { symblst topoldsym=topsym->next; strtype name = topnode->a.label->name; strtype fun_name_old = fun_name; int tree_pt0 = tree_pt; object stop_later = stop_fun; if (name != block_name) { stop_fun = NULL; fun_name = name; } { block_depth++; push_value(topnode->arglst); eval_value(topnode->data.expr); topnode->a.label = topnode->data.expr->a.label; assignsym(topnode, topnode->data.expr); /* Recover symbol table */ topsym->next = pop_value(topoldsym); tree_pt = tree_pt0; block_depth--; } if (name != block_name) { if (stop_fun!=NULL) { topnode->class=VALUE; topnode->data.val=stop_fun; topnode->type=type_of(stop_fun); } stop_fun=stop_later; fun_name = fun_name_old; } } void evalbl_value_dup(symblst result,symblst topnode) { int tree_pt0 = tree_pt; assignsym(result,topnode); result->a.label = topnode->a.label; result->arglst = topnode->arglst; result->data.expr = copytree(result->data.expr); evalbl_value(result); tree_pt = tree_pt0; } void eval_value(symblst topnode) { symblst argsym = topnode->arglst, foundsym; strtype name = topnode->a.label->name; object result; if (topnode->class == DUMMY && type_of(topnode) != UNKNOWN) /* Change variable value after assignment */ { foundsym = srchsym(topsym, name, (symblst) NULL); if (!foundsym) { #if development Printf("System eval_value: symbol %s not found.\n" ,name_tab[name]); #endif error_not_foundsym(topnode); } assignsym(topnode, foundsym); setshared(topnode->data.val); if (isargument) topnode->a.label = foundsym->a.label; } switch (topnode->class) { case VALUE: assign_type_to_node(topnode); return; case MAP: { labeltp label0 = label; label = topnode->a.label; result = (*(symbfobj) topnode->data.f) (argsym); topnode->class = VALUE; topnode->a.label = label_null; topnode->data.val = result; assign_type_to_node(topnode); clear_arguments(topnode->arglst); topnode->arglst = NULL; label = label0; } break; case OPERATOR: { int i = 0; symblst argsym = topnode->arglst; symblst argsym_expected = topnode->data.expr->arglst; object arg[6]; fobject fn = topnode->data.expr->data.f; labeltp label0 = label; label = topnode->a.label; while (argsym!=NULL) { f1object coerc; if (argsym->class != VALUE) eval_value(argsym); clrshared(argsym->data.val); coerc = (f1object) coerc_tab(type_of(argsym),type_of(argsym_expected)); if (coerc) { argsym->data.val = coerc(argsym->data.val); } arg[i] = argsym->data.val; argsym = argsym->next; argsym_expected = argsym_expected->next; i++; } if (argsym_expected && isdefault(argsym_expected)){ if (!defaultgrp) error("Defaultgroup expected.\n"); arg[i++] = defaultgrp; } { switch (i) { case 0: result = (*(f0object)fn)(); break; case 1: result = (*(f1object)fn)(arg[0]); break; case 2: result = (*(f2object)fn)(arg[0], arg[1]); break; case 3: result = (*(f3object)fn)(arg[0], arg[1], arg[2]); break; case 4: result = (*(f4object)fn)(arg[0], arg[1], arg[2], arg[3]); break; case 5: result = (*(f5object)fn)(arg[0], arg[1], arg[2], arg[3], arg[4]); break; case 6: result = (*(f6object)fn)(arg[0], arg[1], arg[2], arg[3], arg[4], arg[5]); break; default: error("To many arguments.\n"); break; } clear_arguments(topnode->arglst); } topnode->class = VALUE; topnode->a.label = label_null; topnode->data.val = result; topnode->arglst = NULL; assign_type_to_node(topnode);/* 7 - 4 - 89 */ label = label0; } break; case FUNCTION_COPIED: { int tree_pt0 = tree_pt; topnode->class = DUMMY; eval_type(topnode); eval_value(topnode); tree_pt = tree_pt0; } break; case BLOCK: for ( ; argsym!=NULL; argsym = argsym->next) { if (argsym->class != VALUE) eval_value(argsym); clrshared(argsym->data.val); } evalbl_value(topnode); break; case DUMMY: { if (name_tab[name][0]=='.') /* topnode has class |MAP| */ for ( ; argsym!=NULL; argsym = argsym->next) { if (argsym->class != VALUE) eval_type(argsym); } else /* topnode has class other than map */ for ( ; argsym!=NULL; argsym = argsym->next) { if (argsym->class != VALUE) eval_value(argsym); } eval_type(topnode); eval_value(topnode); } break; default: error("Illegal class encountered:%s.\n", code_class(topnode->class)); } setshared(topnode->data.val); if (chunks > gccrit) { if (verbose) Printf("Begin garbage collection: %ld (line=%d file=%s)\n", (long)chunks,label->line,label->fname); if (topnode->data.val) mark (topnode->data.val); gc(); if (verbose) Printf("End garbage collection: %ld\n", (long)chunks); if (chunks > gccrit) fatal("Garbage collection doesn't help.\n"); #ifdef dos if (verbose) (void) printf("%ld bytes are available. \n",(long)farcoreleft()); #endif } } static void clear_arguments(symblst argsym) { for ( ; argsym!=NULL; argsym = argsym->next) argsym->data.val = NULL; } LiE/getvalue.h0000644000175000017500000000012110305606502012431 0ustar hakanhakan void eval_value(symblst s); void evalbl_value_dup(symblst result,symblst s); LiE/init.c0000644000175000017500000001057310305606502011567 0ustar hakanhakan#include "lie.h" #define INITFIL "initfile" object defaultgrp = NULL, grp; bigint* one,* null,* minus_one; intcel* bool_false,* bool_true; objcel the_nothing,* nothing=&the_nothing; static poly* create_basic_poly(poly **nulls, index r) { int i; static boolean first = true; poly *result = (poly*) NULL; if (first) { for (i=0; ielm[0][i] = 0; if (r < NPOLY) { nulls[r]=result; setlonglife(result); } return result; } poly *poly_one(index r) { static poly *ones[NPOLY]; poly* result=create_basic_poly(ones, r); result->coef[0] = one; return result; } poly *poly_null(index r) { static poly *zeros[NPOLY]; poly* result= create_basic_poly(zeros, r); result->coef[0] = null; return result; } static void makelink(Symblst a, int n) { int i; symblst new_a=(symblst)a; /* overlapping in memory */ for (i=0; im.nrows, n=a->m.ncols; while (i < m && eqrow_null(*(a->m.elm+i),n)) i++; if (i == m) return true; return false; } boolean Vec_null(object a) { index i, n; n=a->v.ncomp; i=0; while (i < n && *(a->v.compon + i) == 0L) i++; if (i == n) return true; return false; } boolean Pol_null(object a) { index nrows=a->pl.nrows; index i=0; while (i pl.coef[i]->size) i++; if (i == nrows) return true; return false; } void init(void) { int ch; info_depth.n = 0; { if (initfil[0]=='\0') strcpy(initfil, INITFIL); strcpy(dirpath, infofil); strcpy(learnfil, infofil); strcpy(titlefil, infofil); strcat(infofil,"INFO"); strcat(learnfil,"LEARN"); strcat(titlefil,"title"); strcpy(infoind, infofil); strcpy(learnind, learnfil); strcat(infoind,".ind"); strcat(learnind,".ind"); strcpy(monfil, "monfile"); } { init_scanner(); /* must store keywords first */ seq_name=match(".sequence",false); if_name=match(".if",false); assign_name=match(".assign",false); assign_loc_name=match(".assign_loc",false); dollar_name=match("$",false); break_name=match("_break",false); block_name=match("$block",false); return_name=match("_return",false); setdefault_name=match("_setdefault",false); input_fname=name_tab[match("stdin",false)]; } { makelink(static1, nstatic1); makelink(static2, nstatic2); makelink(static3, nstatic3); makelink(static4, nstatic4); makelink(static5, nstatic5); makelink(static6, nstatic6); makelink(static7, nstatic7); } { maxptrs = MAXPTRS_DFLT; initmem(); maxnodes = MAXNODES_DFLT; inittree(); } { one=entry2bigint(1); setlonglife(one); null=entry2bigint(0); setlonglife(null); minus_one=entry2bigint(-1); setlonglife(minus_one); bool_false=mkintcel(0); setlonglife(bool_false); bool_true=mkintcel(1); setlonglife(bool_true); nothing->any.type=VOID; setlonglife(nothing); } { top_definitions=creatsym(match(".top_definitions",false)); add_user_defined(); topsym=creatsym(match(".topsym",false)); topsym->formal=match(".topsym_formal",false); } init_state(); initialize_readline(); { if (!redirected_input) { printf("\nLiE version 2.2.2 created on %s\n" "Authors: Arjeh M. Cohen, Marc van Leeuwen, Bert Lisser.\n", date); { FILE* f= fopen(titlefil,"r"); if (f==NULL) printf("Purpose: development CWI\n\n"); else { while ((ch=getc(f)) != EOF) putchar(ch); fclose(f); } } printf("\ntype '?help' for help information\n" "type '?' for a list of help entries.\n"); } } if (enter_input_file(initfil)) ++lineno; { char* p=getenv("EDITOR"); strcpy(editor, p==NULL ? DEFAULT_EDITOR : p); p=getenv("PAGER"); strcpy(pager, p==NULL ? DEFAULT_PAGER : p); } strcpy(promptlabel,PROMPT); } LiE/init.h0000644000175000017500000000044110305606502011565 0ustar hakanhakan extern object defaultgrp, grp; extern bigint* one,* null,* minus_one; extern intcel* bool_false,* bool_true; extern object nothing; void init(void); boolean Mat_null(object a); boolean Vec_null(object a); boolean Pol_null(object a); poly *poly_one(index r); poly *poly_null(index r); LiE/lexer.c0000644000175000017500000002452310305606502011743 0ustar hakanhakan#include "lie.h" #include "parser.h" #define local static #define STRBLSIZE 500 #define hash_mod 1997 #define shift (c= backed_up ? backed_up=false, next_c : fetch_char()) #define unput(c) (backed_up=true,next_c=c) #define first_semi_keyword HELP #define first_type_id (HELP-6) #define keyword_limit array_size(keyword) #define subject_name_limit 64 int lineno=1; local char* char_point=NULL; local int chars_left=0; char* name_tab[hash_mod]; /* actual names of identifiers */ local short hash_tab[hash_mod]; /* non-negative entries point into |name_tab| array */ local short hash_count=0; symblst symbol_tab[hash_mod]; local char* tok_buf; /* points to currently recorded string */ local int tok_len,tok_buf_size; local int c, next_c; local boolean backed_up=false; /* whether we should use |next_c| next */ local boolean start_of_command; local enum { normal, help, edit, learn, ended } command_type; local boolean ignore_nl; /* whether |'\n'| is treated as space */ local int nesting; /* number of pending opening symbols */ local boolean short_ints; char* keyword[]= { "", "if", "then", "else", "fi", "for", "to", "downto", "in", "row", "while", "do", "od", "loc", "return", "break", "make", "iapply", "vapply", "mapply", "on", "off", "setdefault", "savestate", "restorestate", "mat", "vec", "int", "grp", "tex", "pol", "help", "type", "edit", "read", "write", "monfil", "learn", "exec", "quit", "exit", "listvars", "listfuns", "listops", "maxnodes", "maxobjects" }; char subject_name[subject_name_limit]; local char* store(char* s,int len) { int n= ++len>STRBLSIZE ? len : STRBLSIZE; /* size of new block if needed */ char* result=char_point; if (len>chars_left) result=char_point=alloc_array(char,chars_left=n); char_point+=len; chars_left-=len; return strncpy(result,s,len); } local short hash(char* s) /* |s| is a non-empty string */ { char c; long r=*s++; while ((c=*s++)!='\0') r=(c+(r<<8))%hash_mod; return (short)r; } strtype match(char* str, boolean copy) { short i,h=hash(str); while ((i=hash_tab[h])>=0) if (strcmp(name_tab[i],str)==0) return i; /* identifier found in table */ else if (++h==hash_mod) h=0; /* move past occupied slot */ if (hash_count>=hash_mod-1) fatal("Hash table overflow"); hash_tab[h]= hash_count; /* this number represents the new identifier */ name_tab[hash_count]=copy ? store(str,(int)strlen(str)): str; return hash_count++; } short creatmapname(char *a) { char *s=strcat(strcpy(alloc_array(char,strlen(a)+2),"."),a); short result=match(s,true); free(s); return result; } void clear_symbol_tab(void) { int i; for (i=0; i0) { ignore_nl=false; fetch_line(PROMPT2); } else break; /* stop at non-ignored newline */ } else if (c=='#') { do shift; while (c!='#' && c!='\n' && c!=EOF); if (c!='#') continue; /* |'\n'| requires action, |EOF| must not be skipped */ } else if (!isspace(c)) break; shift; } while(true); } int yylex(void) { short code; if (command_type==ended) return 0; restart: shift; skip_space(); ignore_nl=false; if (c==EOF || c=='\n') { if (c==EOF && cur_in==stdin) stop=true; command_type=ended; return ENTER; } if (command_type!=normal) if (c=='>' && command_type==help) { code= shift!='>' ? unput(c),WRITEHELP : APPENDHELP; command_type=edit; } else { code=ANY_STRING; tok_len=0; do app_c(c),shift; while (c!='\n' && c!=EOF && !(command_type!=learn && (isspace(c) || command_type==help && c=='>')) ); if (command_type==learn) /* then strip trailing spaces */ while (tok_len>0 && isspace(tok_buf[tok_len-1])) --tok_len; app_c('\0'); unput(c); if (command_type!=help) yylval.text=tok_buf; else { sprintf(subject_name,"%.*s",subject_name_limit-1,tok_buf); yylval.text=subject_name; } } else { if (isupper(c)) { char type=c; int next=shift; unput(next); c=type; if (!isalpha(next) && next!='_') /* else fall through for multi-letter identifier */ { if (strchr("ABCDEFGT",type)!=NULL) { code=GROUPID; yylval.sub=type; short_ints=true; } else if (type=='X' || type=='Y') code=X; else error ("Lone `%c' not legal as identifier.\n",type); goto finish; } } if (isalpha(c)) { tok_len=0; do app_c(c), shift; while(isalpha(c) || isdigit(c) || c=='_'); app_c('\0'); unput(c); code=match(tok_buf,true); if (code>= (start_of_command ? keyword_limit : first_semi_keyword)) { yylval.sub=code; code=IDENT; } else if (code>=first_type_id && code': code=RELOP; yylval.sub= shift=='=' ? 5 : (unput(c),3); ignore_nl=true; break; case '+': if (shift=='=') code=PLUSAB; else { unput(c); code=ADDOP; yylval.sub=0; } ignore_nl=true; break; case '-': code=ADDOP; yylval.sub=1; ignore_nl=true; break; case '*': code=TIMES; ignore_nl=true; break; case '/': code=DIVOP; yylval.sub=0; ignore_nl=true; break; case '%': code=DIVOP; yylval.sub=1; ignore_nl=true; break; case '^': code=POWER; ignore_nl=true; break; case '$': code=DOLLAR; tok_len=0; do app_c(c),shift; while(isdigit(c)); app_c('\0'); unput(c); yylval.sub=match(tok_buf,true); break; case ':': code=COLON; command_type=learn; } } short_ints=false; /* flag lasts for one token only */ finish: start_of_command=false; return code; } LiE/lexer.h0000644000175000017500000000050310305606502011740 0ustar hakanhakan extern int lineno; extern char* name_tab[]; extern symblst symbol_tab[]; enum{ empty_str=0 }; extern char* keyword[]; strtype match(char* str, boolean copy); short creatmapname(char *a); void clear_symbol_tab(void); void init_scanner(void); void init_command(void); void clear_input(void); int yylex(void); LiE/lie.h0000644000175000017500000001335510305606502011403 0ustar hakanhakan typedef int boolean; typedef char* string; typedef long entry; /* see also |MaxEntry| and |MinEntry| */ typedef long index; typedef short Short; typedef unsigned short digit; /* see also |MaxDigit| */ typedef unsigned long twodigits; #include "memtype.h" #include "nodetype.h" #include "infolrn.h" typedef struct { objtype type; objclass class; char *name; strtype formal; fobject f; long arglst; long next; } *Symblst, Symbrec; typedef struct { strtype name; objtype type;} nametype; typedef struct { strtype p[N_PARENTS]; short n; } par_tp; typedef int cmp_tp; typedef cmp_tp (*cmpfn_tp) (entry*,entry*,index); #include #include #include #include #include #include #include #include #include #include "lexer.h" #include "getl.h" #include "node.h" #include "mem.h" #include "gettype.h" #include "getvalue.h" #include "init.h" #include "sym.h" #include "main.h" #include "onoff.h" #include "ansi.h" #define false 0 #define true 1 #define MaxEntry LONG_MAX #define MinEntry LONG_MIN #define MaxDigit ((1<<15)-1) #define max_obj_size UINT_MAX #define MAXPTRS_DFLT 99999 #define GCCRIT 1000 \ #define MAXNODES_DFLT 9999 #define LINELENGTH 80 #define NPOLY 10 #define NAMESTACK_LEN 500 #define REPORT_LEN 200 #define LMARGIN 5 #define PROMPT "> " #define PROMPT2 "\\ " #define TO_LOOK 1 #define TO_EDIT 0 #define EXTEND 8 #define RANKMAXSUB 8 #define readmode "rb" #define writemode "wb" #define DEFAULT_EDITOR "emacs" #define DEFAULT_PAGER "less" #define array_size(a) (int)(sizeof(a)/sizeof(a[0])) #define Integer(o) \ (type_of(o)==INTEGER?(o)->i.intval:bigint2entry(&(o)->b)) #define is_int(t) ((t)==INTEGER ||(t)==BIGINT) #define Max(a,b) ((a)>=(b)?(a):(b)) #define Min(a,b) ((a)<=(b)?(a):(b)) #define mul1(num,d) mul1add(num,(digit)(d),(digit)0) #define private_pol(p) ( isshared(p) ? copypoly(p) : p ) #define C0(name,f,res) {res,OPERATOR,name,1,f,0,0}, #define C1(name,f,res,arg1) {arg1,DUMMY,NULL,0,NULL,0,0}, {res,OPERATOR,name,2,f,-1,0}, #define C2(name,f,res,arg1,arg2) \ {arg1,DUMMY,NULL,0,NULL,0,1}, {arg2,DUMMY,NULL,0,NULL,0,0}, \ {res,OPERATOR,name,3,f,-2,0}, #define C3(name,f,res,arg1,arg2,arg3) \ {arg1,DUMMY,NULL,0,NULL,0,1}, {arg2,DUMMY,NULL,0,NULL,0,1}, \ {arg3,DUMMY,NULL,0,NULL,0,0}, {res,OPERATOR,name,4,f,-3,0}, #define C4(name,f,res,arg1,arg2,arg3,arg4) \ {arg1,DUMMY,NULL,0,NULL,0,1}, {arg2,DUMMY,NULL,0,NULL,0,1}, \ {arg3,DUMMY,NULL,0,NULL,0,1}, {arg4,DUMMY,NULL,0,NULL,0,0}, \ {res,OPERATOR,name,5,f,-4,0}, #define C5(name,f,res,arg1,arg2,arg3,arg4,arg5) \ {arg1,DUMMY,NULL,0,NULL,0,1}, {arg2,DUMMY,NULL,0,NULL,0,1}, \ {arg3,DUMMY,NULL,0,NULL,0,1}, {arg4,DUMMY,NULL,0,NULL,0,1}, \ {arg5,DUMMY,NULL,0,NULL,0,0}, {res,OPERATOR,name,6,f,-5,0}, #define M0(name,f,res) {res,MAP,name,1,f,0,0}, #define M1(name,f,res,arg1) \ {arg1,DUMMY,NULL,0,NULL,0,0}, {res,MAP,name,2,f,-1,0}, #define M2(name,f,res,arg1,arg2) \ {arg1,DUMMY,NULL,0,NULL,0,1}, {arg2,DUMMY,NULL,0,NULL,0,0}, \ {res,MAP,name,3,f,-2,0}, #define M3(name,f,res,arg1,arg2,arg3) \ {arg1,DUMMY,NULL,0,NULL,0,1}, {arg2,DUMMY,NULL,0,NULL,0,1}, \ {arg3,DUMMY,NULL,0,NULL,0,0}, {res,MAP,name,4,f,-3,0}, #define M4(name,f,res,arg1,arg2,arg3,arg4) \ {arg1,DUMMY,NULL,0,NULL,0,1}, {arg2,DUMMY,NULL,0,NULL,0,1}, \ {arg3,DUMMY,NULL,0,NULL,0,1}, {arg4,DUMMY,NULL,0,NULL,0,0}, \ {res,MAP,name,5,f,-4,0}, #define M5(name,f,res,arg1,arg2,arg3,arg4,arg5) \ {arg1,DUMMY,NULL,0,NULL,0,1}, {arg2,DUMMY,NULL,0,NULL,0,1}, \ {arg3,DUMMY,NULL,0,NULL,0,1}, {arg4,DUMMY,NULL,0,NULL,0,1}, \ {arg5,DUMMY,NULL,0,NULL,0,0}, {res,MAP,name,6,f,-5,0}, #define A0(name,f,res) \ push(top_definitions,creatopsym(0,match(name,false),f,res)); #define A1(name,f,res,arg1) \ push(top_definitions,creatopsym(1,match(name,false),f,res,arg1)); #define A2(name,f,res,arg1,arg2) \ push(top_definitions,creatopsym(2,match(name,false),f,res,arg1,arg2)); #define A3(name,f,res,arg1,arg2,arg3) \ push(top_definitions,creatopsym(3,match(name,false),f,res,arg1,arg2,arg3)); #define A4(name,f,res,arg1,arg2,arg3,arg4) \ push(top_definitions \ ,creatopsym(4,match(name,false),f,res,arg1,arg2,arg3,arg4)); #define A5(name,f,res,arg1,arg2,arg3,arg4,arg5) \ push(top_definitions \ ,creatopsym(5,match(name,false),f,res,arg1,arg2,arg3,arg4,arg5)); #define FINISH {0,DUMMY,NULL,0,NULL,0,0} extern unsigned long maxnodes, maxptrs, gccrit, maxenters, maxlabels; extern strtype seq_name, if_name, dollar_name, assign_name, assign_loc_name, break_name, return_name, block_name, setdefault_name; extern bigint* (*int2bin) (intcel*); extern intcel* (*bin2int) (bigint*); extern matrix* (*pol2mat) (poly*); extern poly* (*mat2pol) (matrix*) ,* (*vec2pol) (vector*) ,* (*bin2pol) (bigint*) ,* (*int2pol) (intcel*); extern symblst top_definitions,topsym; extern bigint *one, *null, *minus_one; extern intcel *bool_false, *bool_true; extern boolean isargument, check_return; extern int nstatic1,nstatic2,nstatic3,nstatic4,nstatic5, nstatic6,nstatic7; extern Symbrec static1[],static2[],static3[],static4[],static5[], static6[],static7[]; extern boolean am_monitor, prompt, verbose, runtime, gc_set, bigint_set, lprint, parsing; extern FILE *stderr_out, *monfile; extern boolean with_Pre_on; extern int tree_pt, object_pt, block_depth, lex_depth, label_pt, lmargin; extern labeltp label, label_null; /* needed for error messages . */ extern strtype fun_name; extern int line; /* line number needed for error messages */ extern index nrefl; extern boolean alloc_gc; /* whether to use |allocmem| rather than |mlalloc| in |creatsym| */ extern nametype var[]; extern objtype return_stack[]; extern object grp, defaultgrp, repair_obj; extern cmpfn_tp cmpfn; int no_terminal(FILE* f); LiE/non-ANSI.c0000644000175000017500000000022610305606502012140 0ustar hakanhakan #include /* needed for |isatty| */ #include int no_terminal(FILE* f) { return !isatty(fileno(f)); } void sysinit(void) {} LiE/main.c0000644000175000017500000000506610305606502011551 0ustar hakanhakan#include "lie.h" static boolean ignore=true; FILE* cur_in,* cur_out; FILE *monfile = NULL; boolean stop=false; char buffer[LINELENGTH]; char label2[LABELLENGTH]; char monfil[LABELLENGTH]; char infofil[LABELLENGTH]; char infoind[LABELLENGTH]; char initfil[LABELLENGTH]; char learnind[LABELLENGTH]; char learnfil[LABELLENGTH]; char titlefil[LABELLENGTH]; char dirpath[LABELLENGTH]; char promptlabel[LABELLENGTH]; char pager[LABELLENGTH],editor[LABELLENGTH]; int lmargin = 0; labeltp label; strtype fun_name; char* input_fname; int block_depth = 0; object repair_obj = (object) NULL ; symblst topsym, top_definitions; jmp_buf envbuf; boolean parsing=true, isargument=false, alloc_gc=true, redirected_input=false; boolean am_monitor=false, prompt=true, runtime=false, verbose=false, lprint=true, gc_set=true, bigint_set=true; object stop_loop, stop_fun; strtype seq_name, if_name, dollar_name, break_name, return_name, assign_name, assign_loc_name, block_name,setdefault_name; void ignore_intr(void) { ignore=true; } void allow_intr(void) { ignore=false; } static void handle(int sig) { if (ignore) return; while (cur_in != stdin) exit_input_file(false); /* pop input files */ parsing=false; error("\nCalculation aborted\n"); } static void init_loop(void) { topsym ->next=(symblst) NULL; stop_loop=NULL; stop_fun=NULL; parsing=true; tree_pt=0; label_pt=0; block_depth=0; fun_name=0; label=label_null; if (gc_set) gc(); initpar(); if (cur_out != stdout) cur_out=stdout; strcpy(promptlabel,PROMPT); fflush(cur_out); init_command(); /* this also prompts and calls |inputline| */ registrate_cpu(); } int main(int argc, char** argv) { if (no_terminal(stdin)) redirected_input=true; cur_in=stdin; cur_out=stdout; /* these cannot be initialised statically */ { int nr=1; argc--; infofil[0]='\0'; if (argc > 0) { strcpy(initfil,argv[nr++]); argc--; } if (argc > 0) { strcpy(infofil,argv[nr++]); strcat(infofil,"/"); argc--; } if (argc!=0) { printf("Illegal number of arguments.\n"); exit(1); } } init(); ignore_intr(); (void) signal(SIGINT, handle); (void) setjmp(envbuf); /* Finished signal handling and environment set */ while (init_loop(),init_loop_gettype(),yyparse(),!stop) { if (feof(cur_in)) stop=exit_input_file(false); /* close file when fully read */ if (runtime) print_runtime(); } if (!redirected_input) Printf("end program\n"); return 0; } LiE/main.h0000644000175000017500000000166510305606502011557 0ustar hakanhakan void allow_intr(void); void ignore_intr(void); extern FILE* cur_in,* cur_out; extern FILE *monfile; extern char buffer[]; extern char label2[],monfil[], infofil[], infoind[], initfil[], learnind[], learnfil[], titlefil[], dirpath[], promptlabel[], pager[],editor[]; extern int lmargin; extern boolean stop; extern labeltp label; extern strtype fun_name; extern char* input_fname; extern int block_depth; extern object repair_obj; extern symblst topsym, top_definitions; extern jmp_buf envbuf; extern boolean parsing, isargument, alloc_gc, redirected_input; extern boolean am_monitor, prompt, runtime, verbose, lprint, gc_set, bigint_set; extern object stop_loop, stop_fun; extern strtype seq_name, if_name, dollar_name, break_name, return_name, assign_name, assign_loc_name, block_name,setdefault_name; extern int yyparse(void); #ifdef dos extern long farcoreleft(void); #endif extern void add_user_defined(); LiE/mem.c0000644000175000017500000003073410305606502011403 0ustar hakanhakan#include "lie.h" #define hash(p) ((unsigned long)(p)%hash_mod) #define set_common_fields(x,t) ((x)->type=t,(x)->nref=0) #define EXTBIG 16 \ long chunks = 0; /* number of objects currently allocated */ static void **ptr; unsigned long maxptrs=0; /* initialised elsewhere */ static boolean *marked; unsigned long gccrit; static unsigned long hash_mod; static simpgrp* simpgrplist=NULL; void initmem(void) { long i; ptr = (void**) malloc(sizeof(void*) * maxptrs); if (ptr==NULL) fatal("Insufficient memory to allocate object table.\n"); marked = (boolean*) malloc(sizeof(boolean) * maxptrs); if (marked==NULL) fatal("Insufficient memory to allocate mark table.\n"); for (i=0; i=maxptrs) h=0; /* try next slot, wrapping around */ if (i==maxptrs) { free(ptr); ptr=ptr0; free(marked); marked=marked0; maxptrs=maxptrs0; /* reset to old values */ error("You currently cannot decrease 'maxobjects' below %ld.\n" ,chunks); } } ptr[h]=ptr0[k]; /* copy pointer to empty slot */ marked[h]=false; /* make new pointer unmarked */ } } if (!redirected_input) Printf("New object table of size %ld.\n",(long)maxptrs); free(ptr0); free(marked0); /* release the old tables */ } long findaddr0(void* p) { if (p==NULL) return -1; { long i, h = hash(p); for (i=0; i=maxptrs) h=0; } return -1; } long findaddr(void* p) { if (p!=NULL) { long i, h = hash(p); for (i=0; i=maxptrs) h=0; } /* try to give a description of this stranger */ fatal(" findaddr: called with unknown address %p %s\n", p, type_tag(p)); return -1; } static struct { objtype num; char str[4];} type_name [] = { { UNKNOWN, "unk" } , { TEKST, "tex" } , { INTEGER, "int" } , { VECTOR, "vec" } , { MATRIX, "mat" } , { BIGINT, "bin" } , { POLY, "pol" } , { GROUP, "grp" } , { VOID, "vid" } , { ARGTYPE, "arg" } , { GRPDFT, "(g)" } }; objtype type_code(char* name) { int i; for (i=0; i=maxptrs) h=0; if (i==maxptrs) error("Object table overflow (%ld). Try increasing 'maxobjects'.\n" ,chunks); } ignore_intr(); /* don't interrupt while updating |ptr| */ ptr[h]=result; ++chunks; allow_intr(); } return result; } void freem(void* addr) { long i=findaddr(addr); /* locate the pointer; it should be present */ ignore_intr(); ptr[i]=NULL; /* remove pointer from the table */ --chunks; free(addr); /* the actual release of the memory */ allow_intr(); } void freep(poly* addr) { index j; for (j=0; jnrows; j++) { object c=(object) addr->coef[j]; assert(isshared(c)); clrshared(c); freemem(c); } freemem(addr); } entry* mkintarray(index n) { if (n>max_obj_size/sizeof(entry)) error("Cannot create internal array of %ld entries", (long)n); return alloc_array(entry,n); } intcel* (mkintcel)(entry n with_line_and_file) { intcel *i; i = (intcel*) allocmem(sizeof(intcel)); set_common_fields(i,INTEGER); i->intval = n; return i; } bigint* (mkbigint)(long size with_line_and_file) { bigint *result; if (size>SHRT_MAX) error("Big integer too big\n"); result = (bigint*)allocmem(sizeof(bigint)+size*sizeof(digit)); set_common_fields(result,BIGINT); result->allocsize = result->size = size; result->data = (digit *)&result[1]; return result; } bigint* copybigint(bigint* from, bigint* to) { int n = abs(from->size); digit *f, *t; if (to==NULL) to = mkbigint(n); else if (to->allocsizesize = from->size; for (f=from->data, t=to->data; n>0; --n) *t++=*f++; return to; } bigint *extendbigint(bigint* old) { bigint *new; if (old->allocsize>SHRT_MAX-EXTBIG) error("Big integer too big\n"); new = mkbigint(old->allocsize + EXTBIG); copybigint(old, new); freemem(old); return new; } vector* (mkvector)(index n with_line_and_file) { vector *v; if (n > (max_obj_size-sizeof(vector))/sizeof(entry)) error("Cannot handle a vector with %ld entries.\n",(long)n); v=(vector*)allocmem(sizeof(vector)+n*sizeof(entry)); set_common_fields(v,VECTOR); v->size = v->ncomp = n; v->compon = (entry*) &v[1]; return v; } vector* copyvector(vector *src) { vector* result=mkvector(src->ncomp); copyrow(src->compon,result->compon,src->ncomp); return result; } matrix* (mkmatrix)(index r,index c with_line_and_file) { index i; matrix *m; size_t size=sizeof(matrix) + (r==0 ? 1 : r)*(sizeof(bigint*)+sizeof(entry*)) + r*c*sizeof(entry); if (size > max_obj_size) error("Cannot handle a %ld by %ld matrix\n",(long)r,(long)c); m = (matrix*)allocmem(size); set_common_fields(m,MATRIX); m->rowsize = m->nrows = r; m->ncols = c; m->null = (bigint**) NULL; m->elm=(entry**) &m[1]; /* start of row pointer block */ m->elm[0]=(entry*) &m->elm[r]; /* start of entry block */ for (i=1; ielm[i]=&m->elm[i-1][c]; /* remaining row pointers */ return m; } poly* (mkpoly)(index r,index c with_line_and_file) { index i; poly *p; size_t size; boolean is_null_poly = false; if (r == 0) { is_null_poly = true; r = 1; } /* avoid empty polynomial */ size=sizeof(matrix) + r*(sizeof(bigint*)+sizeof(entry*)+c*sizeof(entry)); if (size > max_obj_size) error("Cannot handle a %ld by %ld polynomial\n",(long)r,(long)c); p = (poly*)allocmem(size); set_common_fields(p,POLY); p->rowsize = p->nrows = r; p->ncols = c; p->elm=(entry**) &p[1]; /* start of row pointer block */ p->elm[0]=(entry*) &p->elm[r]; /* start of entry block */ p->coef = (bigint**) &p->elm[0][r*c]; /* start of coefficient block */ for (i=1; ielm[i]=&p->elm[i-1][c]; p->coef[i]=NULL; } if (is_null_poly) { p->coef[0] = null; for (i=0; ielm[0][i] = 0; } return p; } matrix* copymatrix(matrix* old) { index i; matrix* new = mkmatrix(old->nrows,old->ncols); for (i=0; inrows; ++i) copyrow(old->elm[i],new->elm[i],old->ncols); return new; } poly* copypoly(poly* old) { index i; poly* new = mkpoly(old->nrows,old->ncols); for (i=0; inrows; ++i) { new->coef[i]=old->coef[i], setshared(new->coef[i]); copyrow(old->elm[i],new->elm[i],old->ncols); } return new; } matrix* extendmat(matrix* old) { index i; matrix* new= mkmatrix(3*old->rowsize/2+1, old->ncols); for (i=0; inrows; ++i) copyrow(old->elm[i],new->elm[i],old->ncols); new->nrows=old->nrows; freemem(old); return new; } poly* extendpoly(poly* old) { index i; poly* new=mkpoly(3*old->rowsize/2+1,old->ncols); for (i=0; inrows; ++i) { new->coef[i]=old->coef[i],setshared(new->coef[i]); copyrow(old->elm[i],new->elm[i],old->ncols); } new->nrows=old->nrows; freepol(old); return new; } simpgrp* (mksimpgrp)(char type, index rank with_line_and_file) { simpgrp *grp, **loc; { for (loc=&simpgrplist; *loc!=NULL; loc=&(*loc)->nextgrp) if ((*loc)->lietype==type && (*loc)->lierank==rank) return *loc; } grp = (simpgrp *) allocmem(sizeof(simpgrp)); set_common_fields(grp,SIMPGRP); setlonglife(grp); /* simple group will not be garbage collected */ grp->lietype = type; grp->lierank = rank; grp->exponents = grp->level = grp->root_norm = NULL; grp->cartan = grp->icartan = grp->roots = NULL; grp->nextgrp = NULL; /* this group will be last in |simpgrplist| */ return *loc = grp; /* add group to end of |simpgrplist| and return it */ } group* (mkgroup)(index ncomp with_line_and_file) { group *grp; grp = (group*) allocmem(sizeof(group)+ncomp*sizeof(simpgrp*)); set_common_fields(grp,GROUP); grp->toraldim = 0; grp->ncomp = ncomp; grp->liecomp = (simpgrp**)(&grp[1]); return grp; } tekst* (mktekst)(index n with_line_and_file) { tekst *t; t = (tekst*)allocmem(sizeof(tekst)+n+1); set_common_fields(t,TEKST); t->len = n; t->string = (char *) (&t[1]); t->string[n] = '\0'; return t; } tekst* copytekst(tekst* o) { index n = o->len; tekst *result = mktekst(n); strncpy(result->string,o->string,n); return result; } object mkobject(symblst s) { return s->class == BLOCK ? s->data.val : cpobject(s->data.val); } object cpobject(object o) { switch (type_of(o)) { case INTEGER:return (object)mkintcel(o->i.intval); case BIGINT: return (object)copybigint(&o->b,NULL); case VECTOR: return (object)copyvector(&o->v); case MATRIX: return (object)copymatrix(&o->m); case POLY: return (object)copypoly(&o->pl); case GROUP: { group* g=&o->g; index i,n=g->ncomp; group* result=mkgroup(n); result->toraldim=g->toraldim; for (i=0; iliecomp[i] = g->liecomp[i]; return (object) result; } case TEKST: return (object)copytekst(&o->t); default: error("Illegal result type %d\n",type_of(o)); return NULL; } } void mark_expression(symblst s,int n) { int i; for (i = 0; i < n; i++) if (s[i].class == VALUE) mark(s[i].data.val); } static void mark0(void* addr) { if (addr!=NULL) marked[findaddr(addr)] = true; } static boolean markobj(object obj) /* true if it was already marked */ { boolean was_marked = false; long i; if (obj==NULL || islonglife(obj)) return true; { i=findaddr(obj); if (type_of(obj)==POLY) { long k; for (k=0; k< obj->pl.nrows; k++) markobj((object) (obj->pl.coef[k])); } } if (marked[i]) was_marked=true,++obj->i.nref ; else marked[i]=true,obj->i.nref=1; return was_marked; } void mark(object obj) { if (markobj(obj)) return; switch (type_of(obj)) { case SIMPGRP: markobj((object)obj->s.cartan); markobj((object)obj->s.icartan); markobj((object)obj->s.roots); markobj((object)obj->s.exponents); markobj((object)obj->s.level); markobj((object)obj->s.root_norm); break; case GROUP: { int i; for (i=0; ig.ncomp; ++i) mark((object)Liecomp(obj,i)); } } } extern symblst topsym; void gc(void) { long i; strtype name0 = label->name; { symblst v; symblst last_v=top_definitions; label->name = match("garbage_collection",false); /* indicate current activity */ mark(defaultgrp); mark_defaultgrp_stack(); mark((object) topsym); for (v=top_definitions; v!=NULL; v=v->next) { mark0(v); if (v->class==VALUE) mark(v->data.val); else if (v->class == FUNCTION) { funclst f = v->data.func; mark0(f); mark_expression(f->start_nodes, f->n_nodes); /* mark stored function body */ } last_v=v; } mark_tree(); } for (i = 0; iname = name0; /* restore value */ } void for_all_objects(void (*f)(object)) { long i; for (i=0; iany.type & TYPEMASK) #define type_tag(obj) (code_obj_type(type_of(obj))) #define SORTED 0x800 /* whether polynomial or matrix is sorted */ #define issorted(obj) ((((object)(obj))->any.type & SORTED)!=0) #define setsorted(obj) (((object)(obj))->any.type |= SORTED) #define clrsorted(obj) (((object)(obj))->any.type &= ~SORTED) #define LONGLIFE USHRT_MAX /* ref count that marks value as persistent */ #define refcount(x) ((object)(x))->any.nref #define isshared(x) ((x)==NULL ? 0 : refcount(x)) #define setshared(x) ((x)==NULL || refcount(x)==LONGLIFE ? 0 : ++refcount(x)) #define clrshared(x) ((x)==NULL || refcount(x)==LONGLIFE ? 0 : \ refcount(x)==0 ? share_error((object)(x)) : --refcount(x)) #define setlonglife(x) (refcount(x)=LONGLIFE) #define islonglife(x) ((x)!=NULL && refcount(x)==LONGLIFE) #define alloc_array(type_arg,size) \ ((type_arg*)safe_alloc((size)*sizeof(type_arg))) #define freearr(addr) (free(addr)) #define freemem(addr) (refcount(addr)==0 ? freem(addr),0 : 0) #define freepol(addr) (refcount(addr)==0 ? freep(addr),0 : 0) #define with_line_and_file #define Liecomp(grp,i) ((grp)->g.liecomp[i]) void initmem(void); void newmem(long newval); long findaddr0(void* p); long findaddr(void* p); objtype type_code(char* name); char* code_obj_type(objtype t); boolean real_type(objtype type); void* safe_alloc(size_t size); void* allocmem(size_t size); void freem(void* addr); void freep(poly* addr); entry* mkintarray(index n); intcel* (mkintcel)(entry n with_line_and_file); bigint *(mkbigint)(long size with_line_and_file); bigint* copybigint(bigint* from, bigint* to); bigint* extendbigint(bigint* old); vector* (mkvector)(index n with_line_and_file); vector* copyvector(vector *src); matrix* (mkmatrix)(index r,index c with_line_and_file); poly* (mkpoly)(index r,index c with_line_and_file); matrix* copymatrix(matrix* old); poly* copypoly(poly* old); matrix* extendmat(matrix* old); poly* extendpoly(poly* old); simpgrp* (mksimpgrp)(char type, index rank with_line_and_file); group* (mkgroup)(index ncomp with_line_and_file); tekst* (mktekst)(index n with_line_and_file); tekst* copytekst(tekst* o); object mkobject(symblst s); object cpobject(object o); void mark_expression(symblst s,int n); void mark(object obj); void gc(void); void for_all_objects(void (*f)(object)); void printobjectinfo(object obj); LiE/node.c0000644000175000017500000002031310305606502011542 0ustar hakanhakan#include "lie.h" #define full_error error("Reduce space full.\n" \ "Try increasing maxnodes (currently %ld).\n" \ ,(long)maxnodes) #define relocate(p,src_base,dst_base) (p=&(dst_base)[(p)-(src_base)]) static symblst tree_ar; static labeltp label_ar; static labelrec labelrec_null= {0,0,NULL}; static struct { objclass num; char* str;} class_name [] = { { VALUE, "value" } , { OPERATOR, "operator" } , { FUNCTION, "function" } , { FUNCTION_COPIED, "function_copied" } , { MAP, "map" } , { DUMMY, "dum" } , { ARG, "arg" } , { BLOCK, "block" } }; int tree_pt=0, label_pt=0; unsigned long maxnodes=0, maxlabels=0; labeltp label_null=&labelrec_null; symbrec blank_symbol={UNKNOWN,DUMMY,{empty_str},empty_str,{NULL},NULL,NULL}; void inittree(void) { if (maxnodes<2) maxnodes=MAXNODES_DFLT; maxlabels=maxnodes/2; tree_ar=alloc_array(symbrec,maxnodes); label_ar =alloc_array(labelrec,maxlabels); } void newtree(void) { if (tree_pt!=0) fatal("System error. newtree.\n"); freearr(tree_ar); freearr(label_ar); inittree(); Printf("New tree space with maximum number of nodes: %ld.\n", (long) maxnodes); } static void creatnode(symbrec* s,strtype name) { *s=blank_symbol; if (name==empty_str) s->a.label=label_null; else { if (label_pt >= maxlabels) error("Too big program (maxnodes %ld). Try increasing maxnodes.\n" , (long)maxnodes); label_ar[label_pt].name=name; /* name of node */ label_ar[label_pt].line=lineno; label_ar[label_pt].fname=input_fname; /* \LiE. source file and line number */ s->a.label=&label_ar[label_pt++]; } } symblst newnode(labeltp a) { if (tree_pt>=maxnodes) full_error; creatnode(&tree_ar[tree_pt],0); tree_ar[tree_pt].a.label =a; /* use label |a| instead of |label_null| */ return &tree_ar[tree_pt++]; } symblst addnode(int n, strtype name, ...) /* extra arguments have type |(symbrec*)| */ { if (tree_pt >= maxnodes) full_error; creatnode(&tree_ar[tree_pt], name); if (n>0) /* then attach the arguments */ { va_list ap; int i; symblst* t=&tree_ar[tree_pt].arglst; va_start(ap, name); for (i=0; inext; } va_end(ap); } return &tree_ar[tree_pt++]; } symblst addintnode(entry n) { symblst s=addnode(0, empty_str); s->class=VALUE; s->type=INTEGER; s->data.val=(object)mkintcel(n); setshared(s->data.val); return s; } symblst addvecnode(int n) { symblst s=addnode(0, empty_str); s->class=VALUE; s->type=VECTOR; s->data.val=(object)mkvector(n); setshared(s->data.val); return s; } symblst addbigintnode(bigint* b) { symblst s=addnode(0, empty_str); s->class=VALUE; s->type=BIGINT; s->data.val=(object)b; setshared(s->data.val); return s; } symblst addgroupnode(char lietype,index rank) { symblst s=addnode(0,empty_str); s->type=GROUP; s->class=VALUE; if (lietype=='T') { s->data.val=(object) mkgroup((index) 0); s->data.val->g.toraldim=rank; } else { s->data.val=(object) mkgroup((index) 1); Liecomp(s->data.val,0)=mksimpgrp(lietype, rank); } setshared(s->data.val); return s; } symblst addtekstnode(char* t) { symblst s=addnode(0, empty_str); s->class=VALUE; s->type=TEKST; s->data.val=(object)mktekst(strlen(t)); setshared(s->data.val); strcpy(s->data.val->t.string, t); return s; } symblst addnamenode(strtype name) { symblst s=addnode(0,name); s->class=VALUE; s->type=VOID; return s; } symblst addlabelnode(labeltp l) { symblst s=newnode(l); s->class=VALUE; s->type=VOID; return s; } symblst addtypnode(objtype typno) { symblst s=addnode(0, empty_str); s->class=DUMMY; s->type=typno; return s; } symblst addtypnamenode(objtype typno, strtype name) { symblst s=addnode(0, name); s->class=DUMMY; s->type=typno; return s; } symblst addprogramnode(symblst prog) { symblst s=addnode(1, match(".sequence",false),prog); return s; } void addstaynode(object o) { symblst s=newnode(NULL); s->class=VALUE; s->type=type_of(o); s->data.val=o; } char* code_type(objtype typeno) { static char buff[2][8]; static int alt=0; /* alternates between calls */ char* p=buff[alt=1-alt], *s; if ((typeno&FUN)!=0) { strcpy(p,"fun "); typeno&=~FUN; p+=4; } if ((s=code_obj_type(typeno&TYPEMASK))!=NULL) strcpy(p,s); else if ((s=code_obj_type(typeno&(TYPEMASK&~ARR)))!=NULL) { strcpy(p,s); p[2]='l'; } else strcpy(p,"???"); return buff[alt]; } char* code_class(int classno) { static char buff[sizeof("function_copied")+1]; int i; for (i=0; i= maxnodes) full_error; s=tree_ar+tree_pt++; assignsym(s, t); if (s->class==VALUE) { if (!isshared(t->data.val)) t->data.val=NULL; setshared(s->data.val); } s->a.label=t->a.label; s->formal=t->formal; return s; } symblst copytree(symblst s) { symblst r; if (s==NULL) return NULL; r=copynode(s); r->arglst=copytree(s->arglst); r->next=copytree(s->next); if (s->class==BLOCK) r->data.expr=copytree(s->data.expr); return r; } symblst load_function_body(funclst func) { int i,n_nodes=func->n_nodes; symbrec* result=func->top_expr; symblst src=func->start_nodes, dst=&tree_ar[tree_pt]; if ((tree_pt+=n_nodes)>maxnodes) full_error; for (i=0; iarglst!=NULL) relocate(node->arglst,src,dst); if (node->next!=NULL) relocate(node->next,src,dst); if (node->class==BLOCK) relocate(node->data.expr,src,dst); else if (node->class==VALUE) setshared(node->data.val); } relocate(result,src,dst); return result; } funclst store_function_body(symblst arg,symblst expr) { funclst result; int i; result=(funclst) allocmem(sizeof(funcrec)+tree_pt * sizeof(symbrec)+label_pt*sizeof(labelrec)); { result->start_args=(symbrec*) &result[1]; /* arguments and nodes follow |funcrec| */ result->start_labels=(labeltp) &result->start_args[tree_pt]; /* labels follow nodes */ result->n_labels=label_pt; /* all current labels are in this function */ result->n_args= arg==NULL ? 0 : (int)(arg-tree_ar)+1; /* |*arg| is last argument, unless |arg==NULL| */ result->start_nodes= &result->start_args[result->n_args]; /* nodes follow the arguments */ result->top_arg= result->n_args==0 ? NULL : &result->start_args[result->n_args-1]; result->n_nodes=tree_pt-result->n_args; result->top_expr=expr; relocate(result->top_expr,tree_ar,result->start_args); } for (i=0; istart_labels[i]= label_ar[i]; { symblst src=tree_ar, dst=result->start_args; for (i=0; inext!=NULL) relocate(node->next,src,dst); if (node->arglst!=NULL) relocate(node->arglst,src,dst); if (node->class==BLOCK) relocate(node->data.expr,src,dst); if (node->a.label!=label_null) relocate(node->a.label,label_ar,result->start_labels); } } return result; } void mark_tree(void) { mark_expression(tree_ar,tree_pt); } void assign_type_to_node(symblst s) { object t=s->data.val; if (t==NULL && s->type== VOID) return; if (s->type==UNKNOWN || s->type==ARGTYPE || stop_loop!=NULL || stop_fun!=NULL) { s->type= t==NULL ? VOID : type_of(t); return; } if (t!=NULL) { if (s->type==type_of(t)) return; if (coerc_tab(type_of(t),s->type)) { s->type=type_of(t); return; } } error("Type %s expected - type %s computed.\n", code_type(s->type), t?code_type(type_of(t)):"vid"); } void assignobject(symblst s,object t) { s->data.val=t; s->class=VALUE; assign_type_to_node(s); s->a.label=label_null; } object force_integer(symblst topstack) { object i_dex; object top_obj=topstack->data.val; if (!is_int(type_of(top_obj))) error("Integer expected - %s encountered.\n",code_type(type_of( top_obj))); if (!isshared(top_obj) && type_of(top_obj)==INTEGER) { setshared(top_obj); return i_dex=top_obj; } if (type_of(top_obj)==BIGINT) i_dex=(object) (*bin2int)(&top_obj->b); else i_dex=cpobject(top_obj); setshared(i_dex); topstack->data.val=i_dex; assign_type_to_node(topstack); return i_dex; } LiE/nodetype.h0000644000175000017500000000272510305606502012460 0ustar hakanhakan typedef struct symbol symbrec,* symblst; typedef unsigned int strtype; typedef short objclass; typedef object (*fobject)(), /* generic case */ (*f0object) (void), (*f1object) (object), (*f2object) (object,object), (*f3object) (object,object,object), (*f4object) (object,object,object,object), (*f5object) (object,object,object,object,object), (*f6object) (object,object,object,object,object,object); typedef struct { strtype name; int line; char *fname; } *labeltp, labelrec; typedef struct { int n_nodes; int n_labels; int n_args; symblst start_nodes; symblst start_args; labeltp start_labels; symbrec* top_expr; symbrec* top_arg; } funcrec, *funclst; typedef union { char* init_string; strtype name; labeltp label; int size;} atp; struct symbol { objtype type; objclass class; atp a; strtype formal; union { object val; fobject f; symbrec* expr; funclst func; } data; symbrec* arglst; symbrec* next; }; typedef object (*symbfobj) (symblst); enum { FUN =0x0200 /* whether expression has function type */ , DEFAULT =0x0400 /* whether final argument defaults to group */ , ARR =0x0800 /* Dummy list variable length arg */ }; enum { INTFUN=INTEGER|FUN , VECFUN=VECTOR|FUN , MATFUN=MATRIX|FUN , VIDFUN=VOID|FUN , INTLST=INTEGER|ARR , VECLST=VECTOR|ARR , MATLST=MATRIX|ARR , VIDLST=VOID|ARR , ARGLST=ARGTYPE|ARR , GRPDFT=GROUP|DEFAULT }; enum { VALUE, OPERATOR, FUNCTION, DUMMY, MAP, FUNCTION_COPIED, ARG, BLOCK=8 }; LiE/node.h0000644000175000017500000000207410305606502011553 0ustar hakanhakan void inittree(void), newtree(void); symblst newnode(labeltp a); symblst addnode(int n, strtype name, ...); symblst addintnode(entry n), addbigintnode(bigint* b), addvecnode(int n) , addgroupnode(char,index), addtekstnode(char* t); symblst addnamenode(strtype name), addlabelnode(labeltp l) , addtypnode(objtype typno),addtypnamenode(objtype typno, strtype name) , addprogramnode(symblst prog); void addstaynode(object o); char* code_type(objtype typeno),* code_class(int classno); symblst copynode(symblst t),copytree(symblst s); symblst load_function_body(funclst func); funclst store_function_body(symblst arg,symblst expr); void mark_tree(void); void assign_type_to_node(symblst s); void assignobject(symblst s,object t); object force_integer(symblst topstack); extern symbrec blank_symbol; extern int tree_pt, label_pt; extern unsigned long maxnodes, maxlabels; extern labeltp label_null; #define isarrtype(sym) (((sym)->type&ARR)!=0) #define isfuntype(sym) (((sym)->type&FUN)!=0) #define isdefault(sym) ((sym)->next==NULL && ((sym)->type&DEFAULT)!=0) LiE/onoff.c0000644000175000017500000001372610305606502011736 0ustar hakanhakan#include "lie.h" #define local static #define STACK_LEN 100 typedef void (*switch_func_tp)(entry); typedef struct { int runtime, verbose, bigints, gc, prompt, monitor, lex, degree, height, lprint, lmargin; } state_tp; typedef struct { atp a; switch_func_tp fnc_on, fnc_off; int* state;} mode_tp; state_tp state= {OFFCODE, OFFCODE, ONCODE,ONCODE,ONCODE,OFFCODE,PLUS,OFFCODE,OFFCODE,ONCODE,OFFCODE}; cmpfn_tp cmpfn; local struct { int pt; state_tp s[STACK_LEN];} mstack; /* state stack */ local struct { int pt; object defaultgrp[STACK_LEN];} gstack; local void prompt_on(entry unused) { prompt = true; } local void prompt_off(entry unused) { prompt = false; } local void lprint_on(entry unused) { lprint = true; } local void lprint_off(entry unused) { lprint = false; } local void gc_set_on(entry unused) { gc_set = true; } local void gc_set_off(entry unused) { gc_set = false; } local void lmargin_on(entry argument) { lmargin = argument; } local void lmargin_off(entry unused) { lmargin = LMARGIN; } local void monitor_on(entry unused) { if (!am_monitor) if ((monfile = fopen(monfil,"a"))==NULL) error("Cannot open %s.\n",monfil); else am_monitor=true; } local void monitor_off(entry unused) { if (am_monitor) { fprintf(monfile,"\n"); /* make sure last line has ended */ fclose(monfile); monfile = NULL; am_monitor=false; } } local void runtime_on(entry unused) { if (!runtime) registrate_cpu(), runtime=true; } local void runtime_off(entry unused) { if (runtime) print_runtime(), runtime = false; } local void verbose_on(entry unused) { verbose=true; } local void verbose_off(entry unused) { verbose = false; } local void unsort(object x) { if (type_of(x)==MATRIX || type_of(x)==POLY) clrsorted(x); } void unmark_sorted(void) { for_all_objects(unsort); } local void cmpfn_deg_on(entry argument) { cmpfn = argument==MINUS ? deg_decr : (argument=PLUS,deg_incr) ; state.degree=argument; state.lex=OFFCODE; state.height=OFFCODE; unmark_sorted(); } local void cmpfn_lex_on(entry argument) { cmpfn = argument==MINUS ? lex_decr : (argument=PLUS,lex_incr) ; state.degree=OFFCODE; state.lex=argument; state.height=OFFCODE; unmark_sorted(); } local void cmpfn_height_on(entry argument) { cmpfn = argument==MINUS ? height_decr : (argument=PLUS,height_incr) ; state.degree=OFFCODE; state.lex=OFFCODE; state.height=argument; unmark_sorted(); } local void rechain_symbols(symbrec s[],int n) { int i; for (i=n-1;i>=0;i-=s[i].formal) { s[i].next = symbol_tab[s[i].a.name]; symbol_tab[s[i].a.name]=&s[i]; } } local void rebuild_symbol_tab(void) { static boolean first = true; if (!first) clear_symbol_tab(); else first = false; rechain_symbols((symblst)static3,nstatic3); rechain_symbols((symblst)static4,nstatic4); rechain_symbols((symblst)static5,nstatic5); rechain_symbols((symblst)static2,nstatic2); rechain_symbols((symblst)static1,nstatic1); if (bigint_set) rechain_symbols((symblst)static7,nstatic7); else rechain_symbols((symblst)static6,nstatic6); } local void bigint_set_on(entry unused) { static boolean start = true; if (!bigint_set || start) { bigint_set = true; rebuild_symbol_tab(); start = false; } } local void bigint_set_off(entry unused) { if (bigint_set) { bigint_set = false; rebuild_symbol_tab(); } } local mode_tp mode[] = { {{"runtime"},runtime_on, runtime_off, &state.runtime}, {{"verbose"},verbose_on, verbose_off, &state.verbose}, {{"bigints"},bigint_set_on, bigint_set_off, &state.bigints}, {{"gc"}, gc_set_on, gc_set_off, &state.gc}, {{"prompt"},prompt_on,prompt_off, &state.prompt}, {{"monitor"},monitor_on,monitor_off, &state.monitor}, {{"lex"},cmpfn_lex_on, (switch_func_tp) NULL, &state.lex}, {{"degree"},cmpfn_deg_on, (switch_func_tp) NULL, &state.degree}, {{"height"},cmpfn_height_on, (switch_func_tp) NULL, &state.height}, {{"lprint"},lprint_on,lprint_off, &state.lprint}, {{"lmargin"},lmargin_on,lmargin_off, &state.lmargin} }; boolean set_on(entry val, strtype name) { int i = 0; size_t n = sizeof(mode)/sizeof(mode[0]); for (i=0; i= STACK_LEN) error("Not possible to save more options.\n"); mstack.s[mstack.pt++]=state; gstack.defaultgrp[gstack.pt++]=defaultgrp; } local void set_on_off(entry val,strtype name) { if (val == OFFCODE) set_off(val, name); else set_on(val,name); } void restore_state(void) { int i; size_t n=sizeof mode/sizeof *mode; if (mstack.pt==0) error("There are no saved options.\n"); state=mstack.s[--mstack.pt]; for (i=0; iRELOP) switch(code) { static char s[12]; default: return keyword[code]; case APPLY: case TYPEID: case LISTCOMMAND: return keyword[code+yylval.sub]; case HELP: return "?"; case QUIT: return "@"; case WRITEHELP: return ">"; case APPENDHELP: return ">>"; case INT: sprintf(s,"%ld",yylval.val); return s; case NUMBER: return bigint2str(yylval.num); case GROUPID: sprintf(s,"%c",yylval.sub); return s; case IDENT: case DOLLAR: return name_tab[yylval.sub]; case TEXT: { char* t=yylval.sym->data.val->t.string; size_t l=strlen(t); if (l<10) sprintf(s,"\"%s\"",t); else sprintf(s,"\"%.6s...\"",t); return s; } case ANY_STRING: return yylval.text; case ENTER: return ""; case ADDOP: return yylval.sub==0 ? "+" : "-"; case DIVOP: return yylval.sub==0 ? "/" : "%"; } else { static char* s[]={ ";", ",", "|", ":", "(", ")", "{", "}", "[", "]", "||", "&&", "!", "*", "^", "X", "=", "+=" , "==", "!=", "<", ">", "<=", ">=" }; return s[codeclass = BLOCK; blocksym->data.expr = progsym; return blocksym; } void initpar(void) { int i; for (i=0;iformal = name; endsym->formal = match(endname,false); result->arglst = startsym; result->arglst->next = endsym; return result; } static symblst addwhile(strtype fname,symblst condition,symblst prog) { return addnode(2,fname,B(block_name,condition),B(block_name,prog)); } static void check_variable(symblst s) { char *name; name = name_tab[s->a.label->name]; if (s->arglst!=NULL) error("Cannot assign to subscripted compound expression\n"); if (strlen(name)==0) error("Assigning to subscripted non-variable\n"); if (strlen(name)==1 && (name[0] < 'a' || name[0] > 'z')) error("Assigning to subscripted improper variable\n"); } static void write_key(char* name,char* fname, char* mode) { cur_out=fopen(fname,mode); if (cur_out==NULL) { cur_out=stdout; error("Error open for write: %s\n", fname); } printexpr(name,TO_EDIT,false); fclose(cur_out); cur_out = stdout; } LiE/print.c0000644000175000017500000007421710305606502011765 0ustar hakanhakan#include "lie.h" #define local static #define right_margin 70 #define indent(n) Printf("%*s",(int)(n),"") #define entry_width 20 #define NCOLS 6 #define NRECS 512 #define needs_nl (level*strlen(tab) != nc) typedef struct { strtype keyword; long start; short size; short seq; unsigned char narg,t[7]; par_tp parents; boolean directory; } info_ind_tp; typedef struct { char *t[REPORT_LEN]; int pt;} table_tp; typedef struct { info_ind_tp *t[REPORT_LEN]; int pt;} ind_table_tp; static char tab[] = " "; /* 3 spaces */ static short ninfo; static boolean to_show; par_tp info_depth; local ind_table_tp index_table; local table_tp function_table; local entry* max_entry_widths(entry** m, index nrows, index ncols) { char s[entry_width+1]; index i,j; entry* result=mkintarray(ncols); for (j=0; jmax) max=e; else if (e=right_margin) { Printf("\n"); col=indent(start_col+1); wrapped=true; } } col+=Printf("]"); return wrapped ? right_margin : col; } void print_vector(vector* v) { indent(lmargin); print_row(v->ncomp,v->compon,NULL,lmargin); Printf("\n"); } void print_matrix(matrix* m) { if (m->nrows==0) { indent(lmargin); Printf("null(0,%ld)",(long)m->ncols); } else { index i,n=m->nrows; entry* widths=max_entry_widths(m->elm,n,m->ncols); indent(lmargin); Printf("["); for (i=0; incols, m->elm[i],widths,lmargin+1); Printf("\n"); indent(lmargin); Printf(ielm,p->nrows,p->ncols); { bigint* max_coef=null,* min_coef=null; char* c; size_t l; for (i=0; inrows; ++i) { bigint* c=p->coef[i]; if (c->size>0) { if (cmp(c,max_coef)>0) max_coef=c; } else { if (cmp(c,min_coef)<0) min_coef=c; } } c=bigint2str(max_coef); l=strlen(c); freem(c); c=bigint2str(min_coef); coef_width=Max(l,strlen(c)); freem(c); } { int col=indent(lmargin), rowsize; { int start=col; col+=printbigint(p->coef[0],coef_width); col+=Printf("X"); col=print_row(p->ncols, p->elm[0],widths,col); rowsize=col-start; } for (i=1; inrows; ++i) { if (col+rowsize>=right_margin) { Printf(" +\n"); col=indent(lmargin); col+=printbigint(p->coef[i],coef_width); } else { boolean neg=p->coef[i]->size<0; if (neg) p->coef[i]->size=-p->coef[i]->size; /* take absolute value */ col+=Printf(neg ? " -" : " +"); col+=printbigint(p->coef[i],coef_width); if (neg) p->coef[i]->size=-p->coef[i]->size; /* restore sign */ } col+=Printf("X"); col=print_row(p->ncols, p->elm[i],widths,col); } } freearr(widths); Printf("\n"); } void print_mat_bars(matrix* m) { if (m->ncols == 0 || m->nrows == 0) { Printf("(a %ld by %ld matrix)\n", (long)m->nrows, (long)m->ncols); } else { index i,j; entry** a=m->elm; entry* widths=max_entry_widths(a,m->nrows,m->ncols); for (i=0; inrows; ++i) { indent(lmargin); Printf("|"); for (j=0; jncols; ++j) Printf(" %*ld",(int)widths[j],(long)a[i][j]); Printf(" |\n"); } freearr(widths); } } void print_poly_vertical(poly* p) { index i,j; int coef_width=0; entry** a=p->elm; entry* widths=max_entry_widths(a,p->nrows,p->ncols); { bigint* max_coef=null,* min_coef=null; char* c; size_t l; for (i=0; inrows; ++i) { bigint* c=p->coef[i]; if (c->size>0) { if (cmp(c,max_coef)>0) max_coef=c; } else { if (cmp(c,min_coef)<0) min_coef=c; } } c=bigint2str(max_coef); l=strlen(c); freem(c); c=bigint2str(min_coef); coef_width=Max(l,strlen(c)); freem(c); } for (i=0; inrows; ++i) { indent(lmargin); printbigint(p->coef[i],coef_width); Printf(" *"); for (j=0; jncols; ++j) Printf(" %*ld",(int)widths[j],(long)a[i][j]); Printf("\n"); } freearr(widths); } int Printc(char* c) { return Printf("%s",c); } char* grp2str(group* grp) { index i; index n=0; char* buf; for (i=0; incomp; ++i) n+=sprintf(buffer,"%ld",(long)grp->liecomp[i]->lierank); n+=sprintf(buffer,"%ld",(long)grp->toraldim); buf=allocmem(n+grp->ncomp+2); /* one for `\.T', one for |'\0'| */ for (n=0,i=0; incomp; ++i) n+=sprintf(&buf[n],"%c%ld" , grp->liecomp[i]->lietype, (long)grp->liecomp[i]->lierank); if (grp->toraldim>0 || grp->ncomp==0) sprintf(&buf[n], "T%ld", (long)grp->toraldim); return buf; } int printgrp(object obj) { char* buf=grp2str((group*) obj); int n=Printf("%s",buf); freem(buf); return n; } local void listvar(symblst topsym, boolean pr) { object obj; to_show=pr; Printf("\n%s", name_tab[topsym->a.name]); if (pr) Printf(" :%6s", code_type(topsym->type)); else Printf(" ="); obj=topsym->data.val; switch (type_of(topsym)) { case INTEGER: if (pr) Printf("."); Printf("%7ld", obj->i.intval); break; case BIGINT: if (pr) Printf(". "); else Printf("%7s",""); printbigint((bigint*) obj,0); Printf("\n"); break; case VECTOR: if (pr) Printf(". with %ld components", (long)obj->v.ncomp); else { Printf("\n"); print_vector(&obj->v); } break; case MATRIX: if (pr) Printf(". with %ld rows and %ld columns", (long)obj->m.nrows, (long)obj->m.ncols); else { Printf("\n"); print_matrix(&obj->m); } break; case POLY: if (pr) Printf(". with %ld monomials and degree %ld", (long) obj->m.nrows, (long) obj->m.ncols); else { Printf("\n"); print_poly(&obj->pl); } break; case GROUP: if (pr) Printf("."); Printf("\t"); printgrp(obj); break; case TEKST: if (pr) Printf(". with %ld characters", (long)obj->t.len); break; default: if (pr) Printf("."); break; } if (pr && (isshared(obj)>1)) Printf("\t(shared %ld)",(long)(isshared(obj)-1)); Printf("\n"); } local void listop(symblst topsym, boolean pr) { to_show=false; if (!pr) Printf("\n#%7s "," "); else Printf("\n%8s ", " "); writexpr(topsym, -2); Printf("-> %s\n" ,code_type(topsym->type)); } local void listfun(symblst topsym, boolean pr) { symblst arglst=topsym->arglst; to_show=pr; Printf("\n%s (", name_tab[topsym->a.name]); while (arglst) { Printf("%4s", code_type(arglst->type)); Printf(" %s", name_tab[arglst->a.label->name]); if (arglst->next) Printf("; "); arglst=arglst->next; } Printf(") =\n"); writexpr(topsym->data.func->top_expr, -1); Printf("\n"); } local par_tp info_all; /* information independent of directory path */ local par_tp info_silence; local void define_parent(par_tp* a, char* c) { a->n=1; a->p[0] = match(c,false); } local boolean ismap(char* a) { return strcmp(a,"make")==0 || strcmp(a,"iapply")==0 || strcmp(a,"vapply")==0 || strcmp(a,"mapply")==0 || strcmp(a,"imap")==0 || strcmp(a,"vmap")==0 || strcmp(a,"repeat")==0 || strcmp(a,"!")==0; } local void printpath(void) { int i, n=info_depth.n-1; int pt=0; for (i=0; idirectory) { char name[KEYWORDLEN+1]; sprintf(name,"%s>",name_tab[rec->keyword]); Printf("%-12.12s ", name); } else Printf("%-12.12s ", name_tab[rec->keyword]); } Printf("\n"); Printf("\n%-12.12s %-12.12s %-12.12s %-12.12s %-12.12s\n", "path", "index","functions","home",".."); } local short build_info_index(info_ind_tp* info) { FILE* indexpt; short i=0; info_index_tp readinfo; define_parent(&info_all, "all"); define_parent(&info_silence, "silence"); { indexpt=fopen(infoind,readmode); if (!indexpt) { error("File %s cannot be opened.\n",infoind); exit(0); } } rewind(indexpt); while (i= NRECS) error("Indexfile to large.\n"); return i; } local boolean eqarg(symblst arg,info_ind_tp* t) { int i=0; while (i<(int) t->narg && arg && (type_of(arg) == (objtype) t->t[i] #ifdef WITHCOEF || coerc_tab((objtype)t->t[i],type_of(arg)) #endif )) { ++i; arg=arg->next; } return i == (int) t->narg && !arg; } local boolean eq_path(par_tp* p,par_tp* q) { int i=0; if (p->n == q->n) { while (in && p->p[i] == q->p[i]) ++i; if (i == p->n) return true; } return false; } local info_ind_tp* srchinfo (info_ind_tp* info, short ninfo,char* name,symblst arg) { short i=0; while (ipt; char* name=name_tab[rec->keyword]; if (j >= REPORT_LEN) error("Table too small.\n"); while (it[i]->keyword], name)<0) ++i; if (it[i]->keyword], name)==0) return; while (j>i) { table->t[j]=table->t[j - 1]; j--; } table->t[i]=rec; table->pt++; } local void add_function_table(table_tp* table, char* name) { int i=0, j=table->pt; if (j >= REPORT_LEN) error("Table too small.\n"); while (it[i], name)<0) ++i; if (it[i], name)==0) return; while (j>i) { table->t[j]=table->t[j - 1]; j--; } table->t[i]=name; table->pt++; } local void build_index(info_ind_tp* info,short ninfo) { short i; char* name; index_table.pt=0; for (i=0;i=0;i-=s[i].formal) { if (is_a(name_tab[s[i].a.name]) && s[i].class == OPERATOR) add_function_table(&function_table,name_tab[s[i].a.name]); } } local void listop_static(symbrec s[], int n, boolean pr) { int i; for (i=n-1;i>=0;i-=s[i].formal) if (is_a(name_tab[s[i].a.name]) && s[i].class == OPERATOR) listop((symblst) s+i,pr); } local void build_function_table(void) { symblst list=top_definitions; function_table.pt=0; while (list) { if (is_a(name_tab[list->a.name]) && list->class == OPERATOR) add_function_table(&function_table,name_tab[list->a.name]); list=list->next; } build_from_static((symblst)static1,nstatic1); build_from_static((symblst)static2,nstatic2); build_from_static((symblst)static3,nstatic3); build_from_static((symblst)static5,nstatic5); } local void change_path(info_ind_tp* info) { int i; static strtype silence=0; if (!silence) silence=match("silence",false); if (info->parents.n == 1 && info->parents.p[0]==silence) return; for (i=0;iparents.n;++i) info_depth.p[i]=info->parents.p[i]; info_depth.n=info->parents.n; if (info->directory) { info_depth.p[i]=info->keyword; info_depth.n++; } } local boolean printdocument (info_ind_tp* info,short ninfo,char* name,symblst arg,boolean doc) { char* result; info_ind_tp* foundinfo; char infofile[LABELLENGTH]; FILE* infopt; if (!arg && strcmp(name, "functions")==0) { if (!function_table.pt) build_function_table(); if (doc) printfunctions(); return true; } if (!arg && strcmp(name, "index")==0) { build_index(info,ninfo); if (doc) printindex(); return true; } if (name[0] == '$' && strlen(name) != 1) return false; foundinfo=srchinfo(info, ninfo, name, arg); if (!foundinfo) return false; result=(char*) malloc((unsigned long) (foundinfo->size) + sizeof(char)); if (!result) error("No memory left for printing document.\n"); sprintf(infofile,"%s.%ld",infofil,(long)foundinfo->seq); infopt=fopen(infofile,readmode); if (!infopt) error("Not possible to open %s.\n",infofile); fseek(infopt,foundinfo->start,0); fread(result,sizeof(char),foundinfo->size,infopt); result[foundinfo->size]='\0'; /* change search path */ change_path(foundinfo); if (!doc) { int i,nlines=0 ; int n=foundinfo->size; char* resultpt=result; for (i=0;idirectory) /* Print index directory */ { build_index(info,ninfo); if (doc) printindex(); } } free(result); fclose(infopt); return true; } void printexpr(char* c, boolean pr, boolean doc) { int count=0; strtype a; static info_ind_tp* info; symblst top=top_definitions; static char tmpfile[L_tmpnam]; boolean invoke_pager=false; { if (info==NULL) info=(info_ind_tp*) malloc((unsigned long) sizeof(info_ind_tp) * NRECS); if (!info) error("No memory available.%ld %ld\n", (long)sizeof(info_ind_tp), (long)NRECS); } if (c!=NULL) { if (strcmp(c,"..")==0) { if (info_depth.n) info_depth.n--; build_index(info,ninfo); if (doc) { printindex(); printpath(); } return; } if (strcmp(c,"home")==0) { info_depth.n=0; build_index(info,ninfo); if (doc) { printindex(); printpath(); } return; } if (strcmp(c,"path")==0) { printpath(); return; } } if (cur_out==stdout) { tmpnam(tmpfile); cur_out=fopen(tmpfile, "w"); invoke_pager=true; } if (c && c[0] == '.') error("The name %s is reserved.\n",c); if (ninfo==0) ninfo=build_info_index(info); /* get index */ if (strlen(c)>0) if (ismap(c)) a=creatmapname(c); else a=match(c,true); else a=match("help",false); if (strcmp(name_tab[a], "if")!=0 && strcmp(name_tab[a], "for")!=0) for (; top!=NULL; top=top->next) if (top->a.name == a) { switch (top->class) { case FUNCTION: listfun(top, pr); break; case OPERATOR: case MAP: listop(top,pr); break; case VALUE: listvar(top, pr); break; default: break; } count++; if (top->arglst) printdocument(info, ninfo, name_tab[top->a.name], top->arglst, doc); } top=symbol_tab[a]; while (top) { if (top->a.name == a) listop(top,pr); count++; if (top->arglst) printdocument(info, ninfo, name_tab[top->a.name], top->arglst, doc); top=top->next; } if (printdocument(info, ninfo, name_tab[a], NULL,doc)) count++; if (count == 0) Printf("There is no information about the term '%s'.\n",c); if (invoke_pager) { fclose(cur_out); cur_out=stdout; invoke_prog(pager,tmpfile); remove(tmpfile); } if (pr) printpath(); } boolean is_operator(char* aname) { char first=aname&&strlen(aname)?aname[0]:'?'; return (!is_a(aname) && (first != '.') && (first != '_') && (first != '$')); } local int nextline(int indent) { int i; int result=0; /*| if (!to_show) Printf(" \\"); |*/ Printf("\n"); for (i=0; ia.label->name == match(".forint",false)) #define isdownforint (u->a.label->name == match(".downforint",false)) #define isforvec (u->a.label->name == match(".forvec",false)) #define isformat (u->a.label->name == match(".format",false)) #define isstruc (name == match(".strucval",false)) #define isassign (name == match(".assign",false)) #define isupdate (name == match(".update",false)) #define isvecupdate (name == match(".vecupdate",false)) #define isaddupdate (name == match(".+=",false) \ || name == match(".add_and_assign",false)) #define isassign_loc (name == match(".assign_loc",false)) void writexpr(symblst s, short level) { symblst t=s->arglst; boolean bracket=false, c=false, only_name=false; char first; boolean comma=true; static int nc; strtype name= s->a.label? (level>-2 ? s->a.label->name: s->a.name): (strtype) 0; if (level< 0) { nc=0; level=0;} if (name!=empty_str) { first=name_tab[name][0]; c=(t != NULL); if (!is_operator(name_tab[name]) || first == '.' || first == '_' || first == '$') { if (first == '.') { if (isstruc) { bracket=true; c=false; } else if (isseq) { c=false; comma=false; } else if (isif) { if (needs_nl) nc+=nextline(level); nc+=Printc("if "); writexpr(t, level + 1); nc+=Printc(" then "); nc+=nextline(++level); writexpr(t->next->data.expr, level + 1); if (t->next->next) { nc+=nextline(--level); nc+=Printc(" else "); nc+=nextline(++level); writexpr(t->next->next->data.expr, level + 1); } nextline(--level); nc+=Printc("fi"); return; } else if (iswhile) { if (needs_nl) nc+=nextline(level); nc+=Printc("while "); writexpr(t->data.expr, level + 1); nc+=Printc(" do "); level++; nc+=nextline(level); writexpr(t->next->data.expr, level + 1); level--; nc+=nextline(level); nc+=Printc(" od"); return; } else if (isassign) { nc+=Printc(name_tab[t->a.label->name]); nc+=Printc("="); writexpr(t->next, level + 1); return; } else if (isassign_loc) { nc+=Printc("loc "); nc+=Printc(name_tab[t->a.label->name]); nc+=Printc("="); writexpr(t->next, level + 1); return; } else if (isupdate) { symblst lst=t->next->next; nc+=Printc(name_tab[t->a.label->name]); nc+=Printc("[ "); while (lst!=NULL) { writexpr(lst,level+1); lst=lst->next; if (lst!=NULL) nc +=Printc(", "); } nc+=Printc("]="); writexpr(t->next,level+1); return; } else if (isvecupdate) { nc+=Printc(name_tab[t->a.label->name]); nc+=Printc("|"); writexpr(t->next->next,level+1); nc+=Printc("="); writexpr(t->next,level+1); return; } else if (isaddupdate) { symblst s=t->next; nc+=Printc(name_tab[t->a.label->name]); t=t->next; if (t->next!=NULL) /* add update structured element */ { t=t->next; nc+=Printc("["); writexpr(t,level+1); if (t->next!=NULL) { t=t->next; nc+=Printc(","); writexpr(t,level+1); } nc+=Printc("]"); } nc+=Printc("+="); writexpr(s,level+1); return; } else { nc+=Printc(name_tab[name]+1); only_name=!isif && !isseq; } } else if (first == '_') if (name == return_name) { nc+=Printc("return "); c=false; } else if (name == break_name) { nc+=Printc("break "); c=false; } else if (name == setdefault_name) { nc+=Printc("setdefault "); c=false; } else if (name == match("_select",false)) { c=false; bracket=true; writexpr(t, level + 1); t=t->next; } else if (name == match("_on",false)) { entry n=t->data.val->i.intval; nc+=Printc("on "); if (n == -3) nc+=Printc("+ "); if (n == -4) nc+=Printc("- "); if (n >= 0) nc+=Printf("%ld ",(long)n); t=t->next; nc+=Printc(t->data.val->t.string); t=t->next; c=false; } else if (name == match("_off",false)) { nc+=Printc("off "); t=t->next; nc+=Printc(t->data.val->t.string); t=t->next; c=false; } else nc+=Printc(name_tab[name]); else { if (s->class == BLOCK) { symblst u=s->data.expr; if (isforint || isdownforint) { if (needs_nl) nc=nextline(level); nc+=Printc("for "); nc+=Printc(name_tab[s->arglst->formal]); nc+=Printc("="); writexpr(s->arglst, level + 1); isforint? nc+=Printc(" to "):Printc(" downto "); writexpr(s->arglst->next, level + 1); nc+=Printc(" do "); ++level; nc=nextline(level); writexpr(u->arglst->next->data.expr, level); --level; nc=nextline(level); nc+=Printc("od"); return; } if (isforvec || isformat) { if (needs_nl) nc=nextline(level); nc+=Printc("for "); nc+=Printc(name_tab[s->arglst->formal]); if (isforvec) nc+=Printc(" in "); else nc+=Printc(" row "); writexpr(s->arglst->next, level + 1); nc+=Printc(" do "); ++level; nc=nextline(level); writexpr(u->arglst->next->data.expr, level); --level; nc=nextline(level); nc+=Printc("od"); return; } nc+=Printc("{"); writexpr(s->data.expr, level+1); nc+=Printc("}"); return; } nc+=Printc(name_tab[name]); } if (c) nc+=Printc("("); if (bracket) nc+=Printc("["); while (t) { if (only_name) { strtype tname=t->a.label?t->a.label->name:0; if (tname) nc+=Printc(name_tab[tname]); else nc+=Printc(code_type(t->type)); only_name=false; } else writexpr(t, level); t=t->next; if (t) { if (nc>right_margin) nc=nextline(level); nc+=comma ? Printc(",") : Printc(";"); } } if (bracket) nc+=Printc("]"); if (c) nc+=Printc(")"); } else { char* aname=t->a.label?name_tab[t->a.label->name]:(char*) NULL; if (t->next) /* infix */ { if (is_operator(aname)) nc+=Printc("("); writexpr(t, level); if (is_operator(aname)) nc+=Printc(")"); else nc+=Printc(" "); } nc+=Printc(name_tab[name]); if (t->next) t=t->next; if (is_operator(aname)) nc+=Printc("("); else nc+=Printc(" "); writexpr(t, level); if (is_operator(aname)) nc+=Printc(")"); } } else if (type_of(s) == INTEGER && s->class == VALUE) nc+=Printf("%ld", (long)s->data.val->i.intval); else if (type_of(s) == BIGINT && s->class == VALUE) nc+=printbigint((bigint*) s->data.val,0); else if (type_of(s) == GROUP && s->class == VALUE) nc+=printgrp(s->data.val); else if (type_of(s) == TEKST && s->class == VALUE) { nc+=Printc("\""); nc+=Printc((char*) s->data.val->t.string); nc+=Printc("\""); } else nc+=Printc(code_type(s->type)); } #undef isif #undef isseq #undef isblock #undef iswhile #undef isforint #undef isdownforint #undef isforvec #undef isformat #undef isstruc #undef isassign #undef isupdate #undef isvecupdate #undef isaddupdate #undef isassign_loc void printint(object obj) { indent(lmargin); Printf("%ld\n", (long)obj->i.intval); } void printvec(object obj) { int i; indent(lmargin); Printf("["); for (i=0; iv.ncomp; ++i) Printf(" %ld", (long)obj->v.compon[i]); Printf(" ]\n"); } void printtekst(object obj) { indent(lmargin); Printf("%s\n", obj->t.string); } void printgroup(object obj) { indent(lmargin); printgrp(obj); Printf("\n"); } void printlst(symblst topsym) { symblst arglst; if (topsym==NULL) Printf("topsym= NULL \n"); while (topsym!=NULL) { Printf("%10s", code_class(topsym->class)); Printf("%10s ", name_tab[topsym->a.name]); Printf("%10s", code_type(topsym->type)); if (topsym->class == OPERATOR || topsym->class == FUNCTION) { Printf(" <- "); for (arglst=topsym->arglst; arglst!=NULL; arglst=arglst->next) Printf("%10s", code_type(arglst->type)); } Printf("\n"); topsym=topsym->next; } } void listvars(symblst topsym, char* filename) { char tmpfile[L_tmpnam]; if (topsym==NULL) Printf("topsym= NULL\n"); if (pager[0]=='\0') cur_out=stdout; else { if (filename!=NULL) cur_out=fopen(filename, "w"); else { tmpnam(tmpfile); cur_out=fopen(tmpfile, "w"); } if (cur_out==NULL) cur_out=stdout; } Printf("\n # List of defined variables # \n\n"); for (;topsym!=NULL;topsym=topsym->next) if ((topsym->class == VALUE) && (!filename || type_of(topsym) == INTEGER || type_of(topsym) == VECTOR || type_of(topsym) == MATRIX) && (name_tab[topsym->a.name][0] != '$') && (name_tab[topsym->a.name][0] != '.')) listvar(topsym,filename==0); { if (cur_out!=stdout) { fclose(cur_out); cur_out=stdout; if (filename==NULL) { invoke_prog(pager,tmpfile); remove(tmpfile); } } } } void listfuns(symblst topsym, char* filename) { char tmpfile[L_tmpnam]; if (pager[0]=='\0') cur_out=stdout; else { if (filename!=NULL) cur_out=fopen(filename, "w"); else { tmpnam(tmpfile); cur_out=fopen(tmpfile, "w"); } if (cur_out==NULL) cur_out=stdout; } Printf("\n # List of defined functions # \n\n"); for (;topsym!=NULL;topsym=topsym->next) if (topsym->class == FUNCTION && (name_tab[topsym->a.name][0] != '$')) listfun(topsym, filename==NULL); { if (cur_out!=stdout) { fclose(cur_out); cur_out=stdout; if (filename==NULL) { invoke_prog(pager,tmpfile); remove(tmpfile); } } } } void listops(symblst topsym, char* filename, boolean pr) { char tmpfile[L_tmpnam]; if (pager[0]=='\0') cur_out=stdout; else { if (filename!=NULL) cur_out=fopen(filename, "w"); else { tmpnam(tmpfile); cur_out=fopen(tmpfile, "w"); } if (cur_out==NULL) cur_out=stdout; } Printf("\n # List of defined operators # \n\n"); for (;topsym!=NULL;topsym=topsym->next) if (topsym->class == OPERATOR) listop(topsym,pr); listop_static((symblst)static3,nstatic3,pr); { if (cur_out!=stdout) { fclose(cur_out); cur_out=stdout; if (filename==NULL) { invoke_prog(pager,tmpfile); remove(tmpfile); } } } } LiE/sym.c0000644000175000017500000001153310305606502011431 0ustar hakanhakan#include "lie.h" static boolean match_arg(symblst pattern, symblst actual, boolean deflt) { while (pattern!=NULL && actual!=NULL) if ( type_of(actual)!=type_of(pattern) && type_of(pattern)!=ARGTYPE && type_of(actual)!=UNKNOWN && !coerc_tab(type_of(actual),type_of(pattern)) ) return false; else { actual=actual->next; if (!isarrtype(pattern)) pattern=pattern->next; } return actual==NULL && (pattern==NULL || isarrtype(pattern) || deflt&&isdefault(pattern)); } symblst srchsym(symblst table, strtype name, symblst arg) { symblst s; if (table==topsym) /* then search stack first, and user definitions afterwards */ { for (s=table ; s!=NULL; s=s->next) if (s->formal==name) return isargument=true, s; table=top_definitions; } for (s=table ; s!=NULL; s=s->next) if (s->a.name==name && match_arg(s->arglst, arg, false)) return isargument=false, s; for (s=table ; s!=NULL; s=s->next) if (s->a.name==name && match_arg(s->arglst, arg, true)) return isargument=false, s; return isargument=false,s; /* |s==NULL|, not found anywhere */ } void addsym(strtype name, symblst arg, symblst expr, int class) { symblst s; { symblst ref=symbol_tab[name]; /* the permanant bindings */ if (ref!=NULL && srchsym(ref,name,arg)!=NULL) /* one of them matches */ { err_Printf("Sorry, there is a primitive definition for "); error_prototype(name_tab[name],arg); error("\nwhich you cannot redefine.\n"); } } s=srchsym(top_definitions, name, arg); /* if an old binding matches, overwrite it */ if (s==NULL) { s=creatsym(name); s->next=top_definitions->next; top_definitions->next=s; } s->class=class; if (class==FUNCTION) { s->data.func=store_function_body(arg, expr); s->arglst=s->data.func->top_arg; s->type=UNKNOWN; } else if (class==VALUE) { clrshared(s->data.val); assignsym(s,expr); } } symbrec* creatsym(strtype a) { symbrec* s = (symbrec*) allocmem(sizeof(symbrec)); *s=blank_symbol; s->a.name = a; return s; } void error_prototype(string name, symblst arg) { err_Printf("%s(",name); if (arg!=NULL) while (err_Printf("%3s",code_obj_type(type_of(arg))),(arg=arg->next)!=NULL) err_Printf(", "); err_Printf(")"); } void assignsym(symblst s, symblst t) /* |s=t| */ { s->class=t->class; s->type=t->type; s->data=t->data; } void push(symblst l, symblst sym) { sym->next = l->next; l->next=sym; } symblst push_value(symblst list) { symblst* p=&list, q; for (q=list; q!=NULL; q=q->next) /* duplicate list */ { *p=copynode(q); (*p)->arglst=q->arglst; p=&(*p)->next; } *p=topsym->next; return topsym->next=list; /* insert list after |topsym| */ } symblst pop_value(symblst topoldsym) /* clear sharing in stack down to |topoldsym| */ { symblst list; for (list=topsym->next; list != topoldsym; list=list->next) if (list->class==VALUE) clrshared(list->data.val); return topoldsym; } void assignnames(symblst actual, symblst formal) { symblst* p; for (p=&actual->arglst; *p!=NULL; p=&(*p)->next, formal=formal->next) (*p)->formal=formal->a.label->name; if (formal!=NULL) { strtype name=match("_gsetdefault",false); symblst foundsym=srchsym(symbol_tab[name],name,NULL); *p=addnode(0,name), assignsym(*p,foundsym); (*p)->formal=formal->a.label->name; (*p)->data.expr=foundsym; } } void assigntype(objtype t, symblst list) { for ( ;list!=NULL; list=list->next) { list->type= list->next==NULL && t==GROUP ? GRPDFT : t; list->class=DUMMY; } } void add_dollar_names(symblst list) { static char *name[]= {"$1","$2","$3","$4","$5","$6","$7","$8","$9","$10"}; int i; for (i=0; i<10 && list!=NULL; ++i,list=list->next) list->formal=match(name[i],false); if (list!=NULL) error("At most 10 arguments to a block allowed.\n"); } void error_not_foundsym(symblst s) { strtype id=s->a.label->name; char* name = name_tab[id]; label->line = s->a.label->line; /* adjust error indication */ { if (strcmp(name, "_select")==0) error("Impossible to select component from %s.\n" , code_type(s->arglst->type)); if (strcmp(name, ".strucval")==0) error("Array has inconsistent types.\n"); } if (name[0] == '.') ++name; /* skip |'.'| */ { symblst p; for (p=top_definitions; p!=NULL; p=p->next) if (p->a.name==id) goto found; for (p=symbol_tab[id]; p!=NULL; p=p->next) if (p->a.name==id) goto found; if (false) /* i.e., |if (p!=NULL)|; only do next after |goto found|: */ { found: if (s->arglst==NULL) err_Printf("Arguments required for %s.\n",name); else { err_Printf("Argument types do not match in call. Types are: "); error_prototype(name,s->arglst); err_Printf(".\n"); } err_Printf("Valid argument types are for instance: "); error_prototype(name,p->arglst); error(".\n"); } } error("Identifier %s is not defined. \n",name); } LiE/sym.h0000644000175000017500000000135710305606502011441 0ustar hakanhakan void addsym(strtype name, symblst arg, symblst expr, int class); void assignsym(symblst s, symblst t); void push(symblst lst, symblst sym); symblst push_value(symblst list); symblst pop_value(symblst topoldsym); void assignnames(symblst list, symblst name_list); void add_dollar_names(symblst list); symblst srchsym(symblst lst, strtype name, symblst arg); symbrec* creatsym(strtype a); void error_prototype(string name, symblst arg); void assigntype(objtype t, symblst list); void error_not_foundsym(symblst s); #define coerc_tab(t1,t2) \ (t1 == INTEGER && t2 == BIGINT ? (fobject)int2bin : \ t1 == BIGINT && t2 == INTEGER ? (fobject)bin2int : \ (fobject) NULL) #define eq_types(t1,t2) ((t1 == t2) || coerc_tab(t1,t2)) LiE/sysdept.h0000644000175000017500000000162010305606502012315 0ustar hakanhakan #include #include #include #include #include #include #include #include #include /* non-ANSI */ #include typedef long entry; /* see also |MaxEntry| and |MinEntry| */ typedef long index; typedef short Short; typedef unsigned short digit; /* see also |MaxDigit| */ typedef unsigned long twodigits; #define no_terminal(f) (!isatty(fileno(f))) #define sysinit() #define DEFAULT_EDITOR "emacs" #define DEFAULT_PAGER "less" #define MaxDigit ((1<<15)-1) /* bigints are base $2^{15}$ */ #define MaxEntry LONG_MAX #define MinEntry LONG_MIN #define max_obj_size UINT_MAX /* limit for |sizeof(x)| */ #define MAXPTRS_DFLT 999999 #define GCCRIT 1000 /* number of spare locations when calling the garbage collector */ #define MAXNODES_DFLT 6000 #define readmode "r" #define writemode "w" LiE/gapprint.c0000644000175000017500000007374410305606502012461 0ustar hakanhakan#include "lie.h" #define local static #define right_margin 70 #define indent(n) Printf("%*s",(int)(n),"") #define entry_width 20 #define NCOLS 6 #define NRECS 512 #define needs_nl (level*strlen(tab) != nc) typedef struct { strtype keyword; long start; short size; short seq; unsigned char narg,t[7]; par_tp parents; boolean directory; } info_ind_tp; typedef struct { char *t[REPORT_LEN]; int pt;} table_tp; typedef struct { info_ind_tp *t[REPORT_LEN]; int pt;} ind_table_tp; static char tab[] = " "; /* 3 spaces */ static short ninfo; static boolean to_show; par_tp info_depth; local ind_table_tp index_table; local table_tp function_table; local entry* max_entry_widths(entry** m, index nrows, index ncols) { char s[entry_width+1]; index i,j; entry* result=mkintarray(ncols); for (j=0; jmax) max=e; else if (e=right_margin) { Printf("\n"); col=indent(start_col+1); wrapped=true; } } col+=Printf("]"); return wrapped ? right_margin : col; } void print_vector(vector* v) { indent(lmargin); print_row(v->ncomp,v->compon,NULL,lmargin); Printf("\n"); } void print_matrix(matrix* m) { if (m->nrows==0) { indent(lmargin); Printf("null(0,%ld)",(long)m->ncols); } else { index i,n=m->nrows; entry* widths=max_entry_widths(m->elm,n,m->ncols); indent(lmargin); Printf("["); for (i=0; incols, m->elm[i],widths,lmargin+1); Printf("\n"); indent(lmargin); Printf(ielm,p->nrows,p->ncols); { bigint* max_coef=null,* min_coef=null; char* c; size_t l; for (i=0; inrows; ++i) { bigint* c=p->coef[i]; if (c->size>0) { if (cmp(c,max_coef)>0) max_coef=c; } else { if (cmp(c,min_coef)<0) min_coef=c; } } c=bigint2str(max_coef); l=strlen(c); freem(c); c=bigint2str(min_coef); coef_width=Max(l,strlen(c)); freem(c); } { int col=indent(lmargin), rowsize; { int start=col; col+=Printf("["); col+=printbigint(p->coef[0],coef_width); col+=Printf(","); col=print_row(p->ncols, p->elm[0],widths,col); rowsize=col-start; } for (i=1; inrows; ++i) { if (col+rowsize>=right_margin) { Printf("\n"); col=indent(lmargin); Printf(","); col+=printbigint(p->coef[i],coef_width); } else { col+=Printf(","); col+=printbigint(p->coef[i],coef_width); } col+=Printf(","); col=print_row(p->ncols, p->elm[i],widths,col); } Printf("]");} freearr(widths); Printf("\n"); } void print_mat_bars(matrix* m) { if (m->ncols == 0 || m->nrows == 0) { Printf("(a %ld by %ld matrix)\n", (long)m->nrows, (long)m->ncols); } else { index i,j; entry** a=m->elm; entry* widths=max_entry_widths(a,m->nrows,m->ncols); for (i=0; inrows; ++i) { indent(lmargin); Printf("|"); for (j=0; jncols; ++j) Printf(" %*ld",(int)widths[j],(long)a[i][j]); Printf(" |\n"); } freearr(widths); } } void print_poly_vertical(poly* p) { index i,j; int coef_width=0; entry** a=p->elm; entry* widths=max_entry_widths(a,p->nrows,p->ncols); { bigint* max_coef=null,* min_coef=null; char* c; size_t l; for (i=0; inrows; ++i) { bigint* c=p->coef[i]; if (c->size>0) { if (cmp(c,max_coef)>0) max_coef=c; } else { if (cmp(c,min_coef)<0) min_coef=c; } } c=bigint2str(max_coef); l=strlen(c); freem(c); c=bigint2str(min_coef); coef_width=Max(l,strlen(c)); freem(c); } for (i=0; inrows; ++i) { indent(lmargin); printbigint(p->coef[i],coef_width); Printf(" *"); for (j=0; jncols; ++j) Printf(" %*ld",(int)widths[j],(long)a[i][j]); Printf("\n"); } freearr(widths); } int Printc(char* c) { return Printf("%s",c); } char* grp2str(group* grp) { index i; index n=0; char* buf; for (i=0; incomp; ++i) n+=sprintf(buffer,"%ld",(long)grp->liecomp[i]->lierank); n+=sprintf(buffer,"%ld",(long)grp->toraldim); buf=allocmem(n+grp->ncomp+2); /* one for `\.T', one for |'\0'| */ for (n=0,i=0; incomp; ++i) n+=sprintf(&buf[n],"%c%ld" , grp->liecomp[i]->lietype, (long)grp->liecomp[i]->lierank); if (grp->toraldim>0 || grp->ncomp==0) sprintf(&buf[n], "T%ld", (long)grp->toraldim); return buf; } int printgrp(object obj) { char* buf=grp2str((group*) obj); int n=Printf("%s",buf); freem(buf); return n; } local void listvar(symblst topsym, boolean pr) { object obj; to_show=pr; Printf("\n%s", name_tab[topsym->a.name]); if (pr) Printf(" :%6s", code_type(topsym->type)); else Printf(":="); obj=topsym->data.val; switch (type_of(topsym)) { case INTEGER: if (pr) Printf("."); Printf("%7ld", obj->i.intval); break; case BIGINT: if (pr) Printf(". "); else Printf("%7s",""); printbigint((bigint*) obj,0); Printf("\n"); break; case VECTOR: if (pr) Printf(". with %ld components", (long)obj->v.ncomp); else { Printf("\n"); print_vector(&obj->v); } break; case MATRIX: if (pr) Printf(". with %ld rows and %ld columns", (long)obj->m.nrows, (long)obj->m.ncols); else { Printf("\n"); print_matrix(&obj->m); } break; case POLY: if (pr) Printf(". with %ld monomials and degree %ld", (long) obj->m.nrows, (long) obj->m.ncols); else { Printf("\n"); print_poly(&obj->pl); } break; case GROUP: if (pr) Printf("."); Printf("\t\""); printgrp(obj); Printf("\""); break; case TEKST: if (pr) Printf(". with %ld characters", (long)obj->t.len); break; default: if (pr) Printf("."); break; } if (pr && (isshared(obj)>1)) Printf("\t(shared %ld)",(long)(isshared(obj)-1)); Printf(";\n");} local void listop(symblst topsym, boolean pr) { to_show=false; if (!pr) Printf("\n#%7s "," "); else Printf("\n%8s ", " "); writexpr(topsym, -2); Printf("-> %s\n" ,code_type(topsym->type)); } local void listfun(symblst topsym, boolean pr) { symblst arglst=topsym->arglst; to_show=pr; Printf("\n%s (", name_tab[topsym->a.name]); while (arglst) { Printf("%4s", code_type(arglst->type)); Printf(" %s", name_tab[arglst->a.label->name]); if (arglst->next) Printf("; "); arglst=arglst->next; } Printf(") =\n"); writexpr(topsym->data.func->top_expr, -1); Printf("\n"); } local par_tp info_all; /* information independent of directory path */ local par_tp info_silence; local void define_parent(par_tp* a, char* c) { a->n=1; a->p[0] = match(c,false); } local boolean ismap(char* a) { return strcmp(a,"make")==0 || strcmp(a,"iapply")==0 || strcmp(a,"vapply")==0 || strcmp(a,"mapply")==0 || strcmp(a,"imap")==0 || strcmp(a,"vmap")==0 || strcmp(a,"repeat")==0 || strcmp(a,"!")==0; } local void printpath(void) { int i, n=info_depth.n-1; int pt=0; for (i=0; idirectory) { char name[KEYWORDLEN+1]; sprintf(name,"%s>",name_tab[rec->keyword]); Printf("%-12.12s ", name); } else Printf("%-12.12s ", name_tab[rec->keyword]); } Printf("\n"); Printf("\n%-12.12s %-12.12s %-12.12s %-12.12s %-12.12s\n", "path", "index","functions","home",".."); } local short build_info_index(info_ind_tp* info) { FILE* indexpt; short i=0; info_index_tp readinfo; define_parent(&info_all, "all"); define_parent(&info_silence, "silence"); { indexpt=fopen(infoind,readmode); if (!indexpt) { error("File %s cannot be opened.\n",infoind); exit(0); } } rewind(indexpt); while (i= NRECS) error("Indexfile to large.\n"); return i; } local boolean eqarg(symblst arg,info_ind_tp* t) { int i=0; while (i<(int) t->narg && arg && (type_of(arg) == (objtype) t->t[i] #ifdef WITHCOEF || coerc_tab((objtype)t->t[i],type_of(arg)) #endif )) { ++i; arg=arg->next; } return i == (int) t->narg && !arg; } local boolean eq_path(par_tp* p,par_tp* q) { int i=0; if (p->n == q->n) { while (in && p->p[i] == q->p[i]) ++i; if (i == p->n) return true; } return false; } local info_ind_tp* srchinfo (info_ind_tp* info, short ninfo,char* name,symblst arg) { short i=0; while (ipt; char* name=name_tab[rec->keyword]; if (j >= REPORT_LEN) error("Table too small.\n"); while (it[i]->keyword], name)<0) ++i; if (it[i]->keyword], name)==0) return; while (j>i) { table->t[j]=table->t[j - 1]; j--; } table->t[i]=rec; table->pt++; } local void add_function_table(table_tp* table, char* name) { int i=0, j=table->pt; if (j >= REPORT_LEN) error("Table too small.\n"); while (it[i], name)<0) ++i; if (it[i], name)==0) return; while (j>i) { table->t[j]=table->t[j - 1]; j--; } table->t[i]=name; table->pt++; } local void build_index(info_ind_tp* info,short ninfo) { short i; char* name; index_table.pt=0; for (i=0;i=0;i-=s[i].formal) { if (is_a(name_tab[s[i].a.name]) && s[i].class == OPERATOR) add_function_table(&function_table,name_tab[s[i].a.name]); } } local void listop_static(symbrec s[], int n, boolean pr) { int i; for (i=n-1;i>=0;i-=s[i].formal) if (is_a(name_tab[s[i].a.name]) && s[i].class == OPERATOR) listop((symblst) s+i,pr); } local void build_function_table(void) { symblst list=top_definitions; function_table.pt=0; while (list) { if (is_a(name_tab[list->a.name]) && list->class == OPERATOR) add_function_table(&function_table,name_tab[list->a.name]); list=list->next; } build_from_static((symblst)static1,nstatic1); build_from_static((symblst)static2,nstatic2); build_from_static((symblst)static3,nstatic3); build_from_static((symblst)static5,nstatic5); } local void change_path(info_ind_tp* info) { int i; static strtype silence=0; if (!silence) silence=match("silence",false); if (info->parents.n == 1 && info->parents.p[0]==silence) return; for (i=0;iparents.n;++i) info_depth.p[i]=info->parents.p[i]; info_depth.n=info->parents.n; if (info->directory) { info_depth.p[i]=info->keyword; info_depth.n++; } } local boolean printdocument (info_ind_tp* info,short ninfo,char* name,symblst arg,boolean doc) { char* result; info_ind_tp* foundinfo; char infofile[LABELLENGTH]; FILE* infopt; if (!arg && strcmp(name, "functions")==0) { if (!function_table.pt) build_function_table(); if (doc) printfunctions(); return true; } if (!arg && strcmp(name, "index")==0) { build_index(info,ninfo); if (doc) printindex(); return true; } if (name[0] == '$' && strlen(name) != 1) return false; foundinfo=srchinfo(info, ninfo, name, arg); if (!foundinfo) return false; result=(char*) malloc((unsigned long) (foundinfo->size) + sizeof(char)); if (!result) error("No memory left for printing document.\n"); sprintf(infofile,"%s.%ld",infofil,(long)foundinfo->seq); infopt=fopen(infofile,readmode); if (!infopt) error("Not possible to open %s.\n",infofile); fseek(infopt,foundinfo->start,0); fread(result,sizeof(char),foundinfo->size,infopt); result[foundinfo->size]='\0'; /* change search path */ change_path(foundinfo); if (!doc) { int i,nlines=0 ; int n=foundinfo->size; char* resultpt=result; for (i=0;idirectory) /* Print index directory */ { build_index(info,ninfo); if (doc) printindex(); } } free(result); fclose(infopt); return true; } void printexpr(char* c, boolean pr, boolean doc) { int count=0; strtype a; static info_ind_tp* info; symblst top=top_definitions; static char tmpfile[L_tmpnam]; boolean invoke_pager=false; { if (info==NULL) info=(info_ind_tp*) malloc((unsigned long) sizeof(info_ind_tp) * NRECS); if (!info) error("No memory available.%ld %ld\n", (long)sizeof(info_ind_tp), (long)NRECS); } if (c!=NULL) { if (strcmp(c,"..")==0) { if (info_depth.n) info_depth.n--; build_index(info,ninfo); if (doc) { printindex(); printpath(); } return; } if (strcmp(c,"home")==0) { info_depth.n=0; build_index(info,ninfo); if (doc) { printindex(); printpath(); } return; } if (strcmp(c,"path")==0) { printpath(); return; } } if (cur_out==stdout) { tmpnam(tmpfile); cur_out=fopen(tmpfile, "w"); invoke_pager=true; } if (c && c[0] == '.') error("The name %s is reserved.\n",c); if (ninfo==0) ninfo=build_info_index(info); /* get index */ if (strlen(c)>0) if (ismap(c)) a=creatmapname(c); else a=match(c,true); else a=match("help",false); if (strcmp(name_tab[a], "if")!=0 && strcmp(name_tab[a], "for")!=0) for (; top!=NULL; top=top->next) if (top->a.name == a) { switch (top->class) { case FUNCTION: listfun(top, pr); break; case OPERATOR: case MAP: listop(top,pr); break; case VALUE: listvar(top, pr); break; default: break; } count++; if (top->arglst) printdocument(info, ninfo, name_tab[top->a.name], top->arglst, doc); } top=symbol_tab[a]; while (top) { if (top->a.name == a) listop(top,pr); count++; if (top->arglst) printdocument(info, ninfo, name_tab[top->a.name], top->arglst, doc); top=top->next; } if (printdocument(info, ninfo, name_tab[a], NULL,doc)) count++; if (count == 0) Printf("There is no information about the term '%s'.\n",c); if (invoke_pager) { fclose(cur_out); cur_out=stdout; invoke_prog(pager,tmpfile); remove(tmpfile); } if (pr) printpath(); } boolean is_operator(char* aname) { char first=aname&&strlen(aname)?aname[0]:'?'; return (!is_a(aname) && (first != '.') && (first != '_') && (first != '$')); } local int nextline(int indent) { int i; int result=0; /*| if (!to_show) Printf(" \\"); |*/ Printf("\n"); for (i=0; ia.label->name == match(".forint",false)) #define isdownforint (u->a.label->name == match(".downforint",false)) #define isforvec (u->a.label->name == match(".forvec",false)) #define isformat (u->a.label->name == match(".format",false)) #define isstruc (name == match(".strucval",false)) #define isassign (name == match(".assign",false)) #define isupdate (name == match(".update",false)) #define isvecupdate (name == match(".vecupdate",false)) #define isaddupdate (name == match(".+=",false) \ || name == match(".add_and_assign",false)) #define isassign_loc (name == match(".assign_loc",false)) void writexpr(symblst s, short level) { symblst t=s->arglst; boolean bracket=false, c=false, only_name=false; char first; boolean comma=true; static int nc; strtype name= s->a.label? (level>-2 ? s->a.label->name: s->a.name): (strtype) 0; if (level< 0) { nc=0; level=0;} if (name!=empty_str) { first=name_tab[name][0]; c=(t != NULL); if (!is_operator(name_tab[name]) || first == '.' || first == '_' || first == '$') { if (first == '.') { if (isstruc) { bracket=true; c=false; } else if (isseq) { c=false; comma=false; } else if (isif) { if (needs_nl) nc+=nextline(level); nc+=Printc("if "); writexpr(t, level + 1); nc+=Printc(" then "); nc+=nextline(++level); writexpr(t->next->data.expr, level + 1); if (t->next->next) { nc+=nextline(--level); nc+=Printc(" else "); nc+=nextline(++level); writexpr(t->next->next->data.expr, level + 1); } nextline(--level); nc+=Printc("fi"); return; } else if (iswhile) { if (needs_nl) nc+=nextline(level); nc+=Printc("while "); writexpr(t->data.expr, level + 1); nc+=Printc(" do "); level++; nc+=nextline(level); writexpr(t->next->data.expr, level + 1); level--; nc+=nextline(level); nc+=Printc(" od"); return; } else if (isassign) { nc+=Printc(name_tab[t->a.label->name]); nc+=Printc("="); writexpr(t->next, level + 1); return; } else if (isassign_loc) { nc+=Printc("loc "); nc+=Printc(name_tab[t->a.label->name]); nc+=Printc("="); writexpr(t->next, level + 1); return; } else if (isupdate) { symblst lst=t->next->next; nc+=Printc(name_tab[t->a.label->name]); nc+=Printc("[ "); while (lst!=NULL) { writexpr(lst,level+1); lst=lst->next; if (lst!=NULL) nc +=Printc(", "); } nc+=Printc("]="); writexpr(t->next,level+1); return; } else if (isvecupdate) { nc+=Printc(name_tab[t->a.label->name]); nc+=Printc("|"); writexpr(t->next->next,level+1); nc+=Printc("="); writexpr(t->next,level+1); return; } else if (isaddupdate) { symblst s=t->next; nc+=Printc(name_tab[t->a.label->name]); t=t->next; if (t->next!=NULL) /* add update structured element */ { t=t->next; nc+=Printc("["); writexpr(t,level+1); if (t->next!=NULL) { t=t->next; nc+=Printc(","); writexpr(t,level+1); } nc+=Printc("]"); } nc+=Printc("+="); writexpr(s,level+1); return; } else { nc+=Printc(name_tab[name]+1); only_name=!isif && !isseq; } } else if (first == '_') if (name == return_name) { nc+=Printc("return "); c=false; } else if (name == break_name) { nc+=Printc("break "); c=false; } else if (name == setdefault_name) { nc+=Printc("setdefault "); c=false; } else if (name == match("_select",false)) { c=false; bracket=true; writexpr(t, level + 1); t=t->next; } else if (name == match("_on",false)) { entry n=t->data.val->i.intval; nc+=Printc("on "); if (n == -3) nc+=Printc("+ "); if (n == -4) nc+=Printc("- "); if (n >= 0) nc+=Printf("%ld ",(long)n); t=t->next; nc+=Printc(t->data.val->t.string); t=t->next; c=false; } else if (name == match("_off",false)) { nc+=Printc("off "); t=t->next; nc+=Printc(t->data.val->t.string); t=t->next; c=false; } else nc+=Printc(name_tab[name]); else { if (s->class == BLOCK) { symblst u=s->data.expr; if (isforint || isdownforint) { if (needs_nl) nc=nextline(level); nc+=Printc("for "); nc+=Printc(name_tab[s->arglst->formal]); nc+=Printc("="); writexpr(s->arglst, level + 1); isforint? nc+=Printc(" to "):Printc(" downto "); writexpr(s->arglst->next, level + 1); nc+=Printc(" do "); ++level; nc=nextline(level); writexpr(u->arglst->next->data.expr, level); --level; nc=nextline(level); nc+=Printc("od"); return; } if (isforvec || isformat) { if (needs_nl) nc=nextline(level); nc+=Printc("for "); nc+=Printc(name_tab[s->arglst->formal]); if (isforvec) nc+=Printc(" in "); else nc+=Printc(" row "); writexpr(s->arglst->next, level + 1); nc+=Printc(" do "); ++level; nc=nextline(level); writexpr(u->arglst->next->data.expr, level); --level; nc=nextline(level); nc+=Printc("od"); return; } nc+=Printc("{"); writexpr(s->data.expr, level+1); nc+=Printc("}"); return; } nc+=Printc(name_tab[name]); } if (c) nc+=Printc("("); if (bracket) nc+=Printc("["); while (t) { if (only_name) { strtype tname=t->a.label?t->a.label->name:0; if (tname) nc+=Printc(name_tab[tname]); else nc+=Printc(code_type(t->type)); only_name=false; } else writexpr(t, level); t=t->next; if (t) { if (nc>right_margin) nc=nextline(level); nc+=comma ? Printc(",") : Printc(";"); } } if (bracket) nc+=Printc("]"); if (c) nc+=Printc(")"); } else { char* aname=t->a.label?name_tab[t->a.label->name]:(char*) NULL; if (t->next) /* infix */ { if (is_operator(aname)) nc+=Printc("("); writexpr(t, level); if (is_operator(aname)) nc+=Printc(")"); else nc+=Printc(" "); } nc+=Printc(name_tab[name]); if (t->next) t=t->next; if (is_operator(aname)) nc+=Printc("("); else nc+=Printc(" "); writexpr(t, level); if (is_operator(aname)) nc+=Printc(")"); } } else if (type_of(s) == INTEGER && s->class == VALUE) nc+=Printf("%ld", (long)s->data.val->i.intval); else if (type_of(s) == BIGINT && s->class == VALUE) nc+=printbigint((bigint*) s->data.val,0); else if (type_of(s) == GROUP && s->class == VALUE) nc+=printgrp(s->data.val); else if (type_of(s) == TEKST && s->class == VALUE) { nc+=Printc("\""); nc+=Printc((char*) s->data.val->t.string); nc+=Printc("\""); } else nc+=Printc(code_type(s->type)); } #undef isif #undef isseq #undef isblock #undef iswhile #undef isforint #undef isdownforint #undef isforvec #undef isformat #undef isstruc #undef isassign #undef isupdate #undef isvecupdate #undef isaddupdate #undef isassign_loc void printint(object obj) { indent(lmargin); Printf("%ld\n", (long)obj->i.intval); } void printvec(object obj) { int i; indent(lmargin); Printf("["); for (i=0; iv.ncomp; ++i) Printf(" %ld", (long)obj->v.compon[i]); Printf(" ]\n"); } void printtekst(object obj) { indent(lmargin); Printf("%s\n", obj->t.string); } void printgroup(object obj) { indent(lmargin); printgrp(obj); Printf("\n"); } void printlst(symblst topsym) { symblst arglst; if (topsym==NULL) Printf("topsym= NULL \n"); while (topsym!=NULL) { Printf("%10s", code_class(topsym->class)); Printf("%10s ", name_tab[topsym->a.name]); Printf("%10s", code_type(topsym->type)); if (topsym->class == OPERATOR || topsym->class == FUNCTION) { Printf(" <- "); for (arglst=topsym->arglst; arglst!=NULL; arglst=arglst->next) Printf("%10s", code_type(arglst->type)); } Printf("\n"); topsym=topsym->next; } } void listvars(symblst topsym, char* filename) { char tmpfile[L_tmpnam]; if (topsym==NULL) Printf("topsym= NULL\n"); if (pager[0]=='\0') cur_out=stdout; else { if (filename!=NULL) cur_out=fopen(filename, "w"); else { tmpnam(tmpfile); cur_out=fopen(tmpfile, "w"); } if (cur_out==NULL) cur_out=stdout; } Printf("\n # List of defined variables # \n\n"); for (;topsym!=NULL;topsym=topsym->next) if ((topsym->class == VALUE) && (!filename || type_of(topsym) == INTEGER || type_of(topsym) == VECTOR || type_of(topsym) == MATRIX) && (name_tab[topsym->a.name][0] != '$') && (name_tab[topsym->a.name][0] != '.')) listvar(topsym,filename==0); { if (cur_out!=stdout) { fclose(cur_out); cur_out=stdout; if (filename==NULL) { invoke_prog(pager,tmpfile); remove(tmpfile); } } } } void listfuns(symblst topsym, char* filename) { char tmpfile[L_tmpnam]; if (pager[0]=='\0') cur_out=stdout; else { if (filename!=NULL) cur_out=fopen(filename, "w"); else { tmpnam(tmpfile); cur_out=fopen(tmpfile, "w"); } if (cur_out==NULL) cur_out=stdout; } Printf("\n # List of defined functions # \n\n"); for (;topsym!=NULL;topsym=topsym->next) if (topsym->class == FUNCTION && (name_tab[topsym->a.name][0] != '$')) listfun(topsym, filename==NULL); { if (cur_out!=stdout) { fclose(cur_out); cur_out=stdout; if (filename==NULL) { invoke_prog(pager,tmpfile); remove(tmpfile); } } } } void listops(symblst topsym, char* filename, boolean pr) { char tmpfile[L_tmpnam]; if (pager[0]=='\0') cur_out=stdout; else { if (filename!=NULL) cur_out=fopen(filename, "w"); else { tmpnam(tmpfile); cur_out=fopen(tmpfile, "w"); } if (cur_out==NULL) cur_out=stdout; } Printf("\n # List of defined operators # \n\n"); for (;topsym!=NULL;topsym=topsym->next) if (topsym->class == OPERATOR) listop(topsym,pr); listop_static((symblst)static3,nstatic3,pr); { if (cur_out!=stdout) { fclose(cur_out); cur_out=stdout; if (filename==NULL) { invoke_prog(pager,tmpfile); remove(tmpfile); } } } }