yschur.mac

/* Copyright (C) 2013 by Alessandro Campagni */

/*
 * This file is part of YoungTableaux.                                        
 *     YoungTableau is free software: you can redistribute it and/or modify   
 *     it under the terms of the GNU General Public License as published by   
 *     the Free Software Foundation, either version 3 of the License, or      
 *     (at your option) any later version.                                    
 *                                                                            
 *     YoungTableaux is distributed in the hope that it will be useful,       
 *     but WITHOUT ANY WARRANTY; without even the implied warranty of         
 *     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the          
 *     GNU General Public License for more details.                           
 *                                                                            
 *     You should have received a copy of the GNU General Public License      
 *     along with YoungTableaux.  If not, see <http://www.gnu.org/licenses/>.
 *
 *
 * Author: Alessandro Campagni <alessandro@lilik.it>
 */

/* given a tableau T (i.e. a filling T of a diagram λ) returns */
/* the corresponding Schur monomial */
yschur_monomial (T) := block (
  [mon],
  mon : 1,
  /*each (lambda ([l], each (lambda ([i], mon : mon*x[i]), l)), T@word),*/
  for i : 1 thru length (T@word) do block (
    for j : 1 thru length ((T@word)[i]) do block (
      mon : mon*x[(T@word[i])[j]])),
  return (mon)); 

yschur_monomial_word (w) := block (
  [mon],
  mon : 1,
  for i : 1 thru length (w) do block (
    for j : 1 thru length (w[i]) do block (
      mon : mon*x[(w[i])[j]])),
  return (mon));

/* i think this could be the best choice, provided a flatten word */
yschur_monomial_word_recursive (flat_w, mon, i) := block (
  [x],
  if i > 0 then return (yschur_monomial_word_recursive (flat_w, mon*x[flat_w[i]], i-1))
  else return (mon));

/* Given a young diagram D and an alphabet {1,...,m} returns the */
/* corresponding Schur polynomial */
/* naive version */
yschur_polynomial (D, m) := block (
  [pol,n,w,t],
  pol : 0,
  n : ydiagram_size (D),
  lang_size : m^n,
  w : makelist (1, n),
  for i : 1 thru lang_size do block (
    /* print (i,"->",w), */
    t : new_ytableau_safe (w),
    /* print ("same shape? ",yshapep (t,D)), */
    if yshapep (t,D) then block (
      pol : pol + yschur_monomial(t)),
      /* print ("same shape ", t, " ", D)), */
    w : next_lex_word (w, n, m)),
  return (pol));

/* better one */
last_or_zero (l) := if emptyp (l) then 0 else last(l);

fill_line (len, m, ls) := block (
  [],
  if (len = 0) then return (map (lambda ([x], [x]), ls))
  else block (
    /* [p], */
    /* p : [], */
    /* for x in ls do p : append (p, makelist (append (x, [y]), y, last_or_zero (x) + 1, m - len + 1)), */
    ls : xreduce ('append,
      makelist (makelist (append (x, [y]), y, last_or_zero (x) + 1, m - len + 1), x, ls)),
    return (fill_line (len - 1, m, ls))));

/* flatten version of fill_line */
fl_fill_line (len, m, ls) :=
if len = 0 then ls
else fl_fill_line (len - 1, m,
  xreduce ('append, makelist (makelist (append (x, [y]), y, last_or_zero (x) + 1, m - len +1), x, ls)));

fill_next_line (len, m, prev, ls) := block (
  [],
  if (len = 0) then return (ls)
  else block (
    [p],
    p : [],
    for x in ls do p : append (p,
      makelist (append (x, [y]), y, max (last_or_zero (x) + 1, prev[length (x)+1]), m - len + 1)),
    return (fill_next_line (len - 1, m, prev, p))));

/* shape should be rows of Young diagram, actually the conjugate of the diagram */
/* we are trying to fill list in reversed order */
/* level should be 0, it is the last level filled. */
/* ts should be [[]], m is the size of the alphabet. */
list_transposed_ytableaux (shape, level, m, ts) := block (
  [],
  if (level = length (shape)) then return (ts)
  else block (
    [],
    if (level = 0) then return (list_transposed_ytableaux (shape, level + 1, m, fill_line (shape[level + 1], m, ts)))
    else block (
      [ts_first, nls, nts],
      if emptyp (flatten (ts)) then return ([]),
      ts_first : first (ts),
      ts : delete (ts_first, ts),
      /* this was an ugly workaround to bug in fill_line fixed in d67b93d */
      /* if listp (first (ts_first)) then curr : first (ts_first) */
      /* else block ( */
      /*   print ("listp (first (ts_first)) is false"), */
      /*   curr : ts_first, */
      /*   ts_first : [ts_first]), */
      nls : fill_next_line (shape [level+1], m, first (ts_first), [[]]), /* first (ts_first) was curr */
      nts : map (lambda ([x], append ([x], ts_first)), nls),
      ts : append (ts, nts),
      if every (lambda ([x], is (length (flatten (x)) = length (flatten (first (ts))))), ts) then level : (level + 1),
      return (list_transposed_ytableaux (shape, level, m, ts)))));

/* flatten version */
fl_list_transposed_ytableaux (shape, level, m, ts) :=
if level < length (shape) then
if level > 0 then
if not emptyp (flatten (ts)) then block (
  [nls,ts_first],
  ts_first : first (ts),
  ts : delete (ts_first, ts),
  nls : fill_next_line (shape [level+1], m, rest (ts_first, - length (ts_first) + shape[level]), [[]]),
  ts : append (ts, map (lambda ([x], append (x, ts_first)), nls)),
  if every (lambda ([x], is (length (flatten (x)) = length (flatten (first (ts))))), ts) then level : (level + 1),
  fl_list_transposed_ytableaux (shape, level, m, ts)) else []
else fl_list_transposed_ytableaux (shape, level + 1, m, fl_fill_line (shape[level + 1], m, ts))
else ts;

/* Schur monomial from a tableau is the same of the one frome the transposed of that tableau */
better_yschur_polynomial (d, m) := block (
  [ts, pol, shape],
  shape : reverse ((ydiagram_transpose (d))@rows),
  print (shape),
  ts : list_transposed_ytableaux (shape, 0, m, [[]]),
  pol : 0,
  for i : 1 thru length (ts) do pol : pol + yschur_monomial_word (ts[i]),
  return (pol));

fl_better_yschur_polynomial (d, m) := block (
  [ts, pol, shape],
  shape : reverse ((ydiagram_transpose (d))@rows),
  print (shape),
  ts : fl_list_transposed_ytableaux (shape, 0, m, [[]]),
  pol : 0,
  for i : 1 thru length (ts) do pol : pol + yschur_monomial_word_recursive (ts[i], 1, length (ts[i])),
  return (pol));

fl_better_yschur_polynomial_rows (d, m) := block (
  [ts, pol, shape],
  d : new_ydiagram_safe (d),
  shape : reverse ((ydiagram_transpose (d))@rows),
  print (shape),
  ts : fl_list_transposed_ytableaux (shape, 0, m, [[]]),
  pol : 0,
  for i : 1 thru length (ts) do pol : pol + yschur_monomial_word_recursive (ts[i], 1, length (ts[i])),
  return (pol));

/* list_ytableaux (d, m) := block ( */
/*   [tts, reversed_shape], */
/*   reversed_shape : reverse (d@rows), */
/*   tts : list_transposed_ytableaux (reversed_shape, 0, m, [[]]), */
/*   return (map (lambda ([x], remove_tableau_column (x, [])), tts))); */