// $Source$
// $Revision$
// $Date$


//***********************************  ************************************
//*********** Упорядоченное хранилище клешей и операции с ним *************

$use Access Apply Arithm Box Compare List StdIO Table;

$use "rfp_const";
$use "rfp_vars";
$use "rfp_compile";


/*
 * Собственно, хранилище.
 */
$box Clashes;
/*
 * Хранятся в нём клеши в следующем формате:
 *
 * t.clash ::= (s.idx (e.Re) (s.dir e.Pe) e.boxes)
 *
 * e.boxes -- список ящиков, обозначающих свойства данного клеша.  В этих
 * ящиках находятся номера клешей, обладающих заданным свойством и, возможно,
 * некая дополнительная информация для каждого клеша.
 *
 * 
 * Ящики бывают следующие.
 * 
 */


/*
 * Образец может иметь жёсткие по длине части слева и справа.  Сопоставление с
 * этими частями выливается в проверку условий возможности такого сопоставления
 * и заведение новых переменных.  Всё это делается до компиляции циклической
 * части образца.
 *
 * В результате означивания новых переменных, жёсткие части образца могут
 * удлинняться.  Следующая таблица по индексу клеша хранит запись вида:
 * (e.left) (e.right) expr.
 * e.left  -- выражение, в ран-тайм получающее значение длины жёсткой части
 * слева.
 * e.right -- аналогичное выражение для длины жёсткой части справа.
 * expr    -- часть выражения между жёсткими кусками.
 */
$table Hard_Parts;


$box Parenth;


$box Unready_Source;





$func Add_Clash_To_Var e = e;

Add_Clash_To_Var t.clash t.var =
  <Set_Var (Clashes <Get_Var Clashes t.var> t.clash) t.var>;

$func Classify_Lengths t.clash = e.boxes;

Classify_Lengths (s.idx (e.Re) (s.dir e.Pe) e) =
  <Get_Known_Length e.Re> :: e.len_Re (e.vars_Re),
  <Get_Known_Length e.Pe> :: e.len_Pe (e.vars_Pe),
  {
    /*
     * Если длины всех переменных на верхних уровнях e.Re и e.Pe
     * известны, кладём клеш в ящик &Known-Lengths.
     */
    e.vars_Re : /*empty*/, e.vars_Pe : /*empty*/ =
      <Bind &Known_Lengths (s.idx) ((e.len_Re) (e.len_Pe))>,
      &Known_Lengths;
    /*
     * Если на верхнем уровне во всём клеше ровно одна переменная с
     * неизвестной длинной, и она входит в левую и правую части разное
     * кол-во раз, то её длину можно вычислить.
     * В каждой переменной делаем пометку, что она используется в этом клеше.
     * Кладём клеш в ящик &Compute-Length.
     */
    <Arithm.Sub <Length e.vars_Re> <Length e.vars_Pe>> :: s.diff,
      <Ne (s.diff) (0)>,
      <Nub e.vars_Re e.vars_Pe> : t.var =
      {
        <Lt (s.diff) (0)> = <Mult s.diff -1> (e.len_Re) (e.len_Pe);
        s.diff (e.len_Pe) (e.len_Re);
      } :: s.mult (e.minuend) (e.subtrahend),
      <Map &Add_Clash_To_Var s.idx (e.vars_Re e.vars_Pe)> : e,
      <Bind &Compute_Length (s.idx) (t.var s.mult (e.minuend) (e.subtrahend))>,
      &Compute_Length;
    /*
     * В оставшихся случаях, всё, что мы можем сделать -- выписать
     * граничные условия и ждать, пока не появится новой информации о длине
     * каких-либо переменных.
     * В каждой переменной делаем пометку, что она используется в этом клеше.
     * Кладём клеш в таблицу &Unknown-Lengths.
     */
    <Map &Add_Clash_To_Var s.idx (e.vars_Re e.vars_Pe)> : e,
      <Bind &Unknown_Lengths
        (s.idx) ((e.len_Re) (e.len_Pe) (e.vars_Re) (e.vars_Pe))>,
      &Unknown_Lengths;
  };


/*
 * Может оказаться, что клеша с номером s.idx уже нет в хранилище -- из памяти
 * переменных клеши не удаляются.  В этом случае просто не надо ничего делать.
 */
Reclassify_Clash s.idx, {
  <Get &Clashes> : e1 (s.idx (e.Re) (s.dir e.Pe) e.boxes) e2,
  <List.Sub (e.boxes) &Compute_Length &Unknown_Lengths> :: e.boxes1,
  <Unbind &Compute_Length s.idx>,
  <Unbind &Unknown_Lengths s.idx>,
  <Classify_Lengths (s.idx (e.Re) (s.dir e.Pe))> :: e.boxes2,
  <Store &Clashes e1 (s.idx (e.Re) (s.dir e.Pe) e.boxes1 e.boxes2) e2>;;
};



//********************* Индекс для нумерации клешей ***********************

$box FreeIdx;

$func Free_Index = s.idx;

Free_Index =
  <Get &FreeIdx> : s.idx,
  <Store &FreeIdx <Arithm.Add s.idx 1>>,
  s.idx;



//**************************** Инициализация ******************************

$func Compose_Clashes e.clashes = e.clashes;

Init_Clashes e.clashes =
  <ClearTable &Known_Lengths>,
  <ClearTable &Compute_Length>,
  <ClearTable &Unknown_Lengths>,
  <Store &Checked_Lengths /*empty*/>,
  <Store &Eqs /*empty*/>,
  <Store &Parenth /*empty*/>,
  <Store &Unready_Source /*empty*/>,
  <ClearTable &Hard_Parts>,
  <Store &FreeIdx 0>,
  <Store &Clashes <Compose_Clashes e.clashes>>;

Compose_Clashes {
  (e.Re) (s.dir e.Pe) e.rest =
    <Free_Index> :: s.idx,
    <Classify_Lengths (s.idx (e.Re) (s.dir e.Pe))> :: e.boxes,
    {
      \{
        <Get_Var "Instantiated?" e.Re> : True;
        e.Re : (REF e);
        e.Re : (STATIC e);
      };
      e.Pe : e1 (PAREN e) e2 =
        <Vars e.Re> :: e.Re_vars,
        <Put &Parenth (s.idx (e.Re_vars) <Vars e1>)>,
        {
          e2 : $r e (PAREN e) e3 =
            <Put &Parenth (s.idx (e.Re_vars) <Vars e3>)>;;
        },
        <Put &Unready_Source (s.idx e.Re_vars)>;
      <Put &Unready_Source (s.idx <Vars e.Re>)>;
    },
    (s.idx (e.Re) (s.dir e.Pe) e.boxes) <Compose_Clashes e.rest>;;
};




//****** Обновление информации о жёстких началах и концах образцов ********

$func UHP (e.conds) (e.assigns) e.clashes = e.clashes (e.actions);

$func UHP_Clash s.dir s.fun s.l s.r (e.conds) (e.assigns) (e.pos) (e.Re) e.Pe =
  e.clashes (e.conds) (e.assigns) (e.pos) (e.Pe);

/*
 * Просматриваем все имеющиеся клеши.
 * Если в результате новой информации о переменных, входящих в образец, можно
 * утверждать что жёсткие части удлиннились, запоминаем эту информацию в
 * таблице &Hard-Parts, заводим новые клеши, получающиеся из скобок в образце,
 * и возвращаем условия и присваивания, нужные, чтобы завести эти клеши.
 * Новые, входящие в жёсткие, части образца, не являющиеся скобками, кладутся в
 * ящик &Eqs вместе с результатным выражением и с позицией в этом выражении с
 * которой надо эти части сопоставлять.
 */
Update_Hard_Parts =
  <UHP () () <Get &Clashes>> :: e.clashes (e.actions),
  <Store &Clashes e.clashes>,
  e.actions;

UHP (e.conds) (e.assigns) e.clashes, e.clashes : {
  t.clash e.rest,
    t.clash : (s.idx (t.Re) (s.dir e.Pe) e),
    \{
      <Get_Var "Instantiated?" t.Re> : True;
      t.Re : (REF e);
      t.Re : (STATIC e);
    } =
    {
      <Lookup &Hard_Parts s.idx>;
      (0) (0) e.Pe;
    } : (e.left) (e.right) expr,
    <UHP_Clash s.dir &L 1 0 () () (e.left ) (t.Re) expr>
      :: e.l_clashes (e.l_conds) (e.l_assigns) (e.left ) (expr),
    <UHP_Clash s.dir &R 0 1 () () (e.right) (t.Re) expr>
      :: e.r_clashes (e.r_conds) (e.r_assigns) (e.right) (expr),
    <Bind &Hard_Parts (s.idx) ((e.left) (e.right) expr)>,
    <Compose_Clashes e.l_clashes> t.clash <Compose_Clashes e.r_clashes>
    <UHP (e.conds e.l_conds e.r_conds) (e.assigns e.l_assigns e.r_assigns) e.rest>;
  t.unready_clash e.rest = t.unready_clash <UHP (e.conds) (e.assigns) e.rest>;
  /*empty*/ = (e.conds e.assigns);
};

/*
 * Функция, занимающаяся непосредственно проверкой составляющих образца на
 * вычислимость длин, начиная слева или справа, в зависимости от s.dir.
 * 
 * Если очередной терм -- это скобки, то должен быть заведён новый клеш,
 * образованный из содержимого скобок.  Перед этим надо произвести проверку на
 * то, что в результатном выражении в этом месте тоже стоят скобки, и завести
 * переменную, обозначающую их содержимое.
 * Данная функция возвращает всю информацию, необходимую для этих действий.
 */
UHP_Clash s.dir s.fun s.l s.r (e.conds) (e.assigns) (e.pos) (e.Re) e.Pe, {
  e.Pe : v, <Apply s.fun 0 e.Pe> : t.Pt, {
    <Get_Known_Length t.Pt> : e.len (), {
      t.Pt : (PAREN expr) = 
        <Gener_Vars ((VAR)) "deref_" e.Re> : t.var,
        <Set_Var ("Instantiated?" True) t.var>,
        {
          s.fun : &R = RIGHT e.pos 1;
          LEFT e.pos;
        } :: e.pos,
        (("SYMBOL?" e.Re (e.pos)))
        ((DEREF t.var e.Re (e.pos)))
        (t.var) (s.dir expr);
      {
        s.fun : &R = <Put &Eqs ((e.Re) (RIGHT e.pos e.len) t.Pt (e.len))>;
        <Put &Eqs ((e.Re) (LEFT e.pos) t.Pt (e.len))>;
      },
        () () /*empty*/;
    } :: (e.cond) (e.assign) e.clash =
      e.clash
      <UHP_Clash s.dir s.fun s.l s.r (e.conds e.cond) (e.assigns e.assign)
        (e.pos e.len) (e.Re) <Middle s.l s.r e.Pe>>;
    (e.conds) (e.assigns) (e.pos) (e.Pe);
  };
  (e.conds) (e.assigns) (e.pos) ();
};




$func Prepare_Source e.source = t.var e.assign;

$func Define_Vars e.vars = e.eqs;

Prepare_Source {
  t.Re, \{
    <Get_Var "Instantiated?" t.Re> : True;
    t.Re : (REF e);
    t.Re : (STATIC e);
  } =
    t.Re /*empty*/;
  t.Re, <IsVar t.Re> =
    t.Re <Define_Vars t.Re>;
  e.Re =
    <Gener_Vars ((EVAR)) "compose"> : t.var,
    <Set_Var ("Instantiated?" True) t.var>,
    <Vars_Decl Expr t.var> : e, // ???
    t.var <Define_Vars <Vars e.Re>> (DECL Expr <Vars_Print t.var>) (ASSIGN <Vars_Print t.var> e.Re);
};

Define_Vars {
  t.var e.rest =
    {
      <Get_Var "Instantiated?" t.var> : True = <Define_Vars e.rest>;
      <Get &Eqs> : e1 (t.Re t.pos t.var t.len) e2 =
        <Store &Eqs e1 e2>,
        (t.Re t.pos t.var t.len) <Define_Vars e.rest>;
    };
  /*empty*/ = /*empty*/;
};



$func Find_SFD e.parenth = e.parenth (e.idx);

$func? Not_Instantiated_Var e = e;

$func? Not_Idx e = e;

Not_Idx {
  s.idx (s.idx e) = $fail;
  e.else_true;
};

Compose_Source = \{
  <Find_SFD <Get &Parenth>> : e.parenth (s.idx) =
    <Store &Parenth e.parenth>,
    <Store &Unready_Source <Filter &Not_Idx s.idx (<Get &Unready_Source>)>>,
    s.idx;
  <Get &Unready_Source> : e.l (s.idx e.vars) e.r,
    <Filter &Not_Instantiated_Var (e.vars)> : /*empty*/ =
    <Store &Unready_Source e.l e.r>,
    <Store &Parenth <Filter &Not_Idx s.idx (<Get &Parenth>)>>,
    s.idx;
} :: s.idx,
  {
    <Get &Clashes> : e1 (s.idx (e.Re) (s.dir e.Pe) e.boxes) e2,
      <Prepare_Source e.Re> :: t.var e.assign,
      <Store &Clashes e1 (s.idx (t.var) (s.dir e.Pe) e.boxes) e2>,
      e.assign;
  };

Find_SFD {
  (s.idx (e.Re_vars) e.Pe_vars) e.rest =
    <Filter &Not_Instantiated_Var (e.Re_vars)> : {
      v.r_vars = (s.idx (v.r_vars) e.Pe_vars) <Find_SFD e.rest>;
      /*empty*/ = <Get_Known_Length e.Pe_vars> : {
        e (v.p_vars) = (s.idx () v.p_vars) <Find_SFD e.rest>;
        e () = <Filter &Not_Idx s.idx (e.rest)> (s.idx);
      };
    };
  /*empty*/ = ();
};

Not_Instantiated_Var t.var = # \{
  <Get_Var "Instantiated?" t.var> : True;
  <Get &Eqs> : e (t t t.var t) e;
};



Get_Cycle =
  <Get &Clashes> : e (s.idx (t.var) (s.dir e.Pe) e.b1 &Unknown_Lengths e.b2) e.rest =
  <Get_Known_Length t.var> : e.len (),
  <Lookup &Hard_Parts s.idx> : (e.left) (e.right) e.expr,
  s.dir : {
    LEFT =
      e.expr : t.var_e1 e.Pe_rest,
      LSPLIT t.var_e1 "lsplit_" e.Pe_rest;
    RIGHT =
      e.expr : e.Pe_rest t.var_e1,
      RSPLIT t.var_e1 "rsplit_" e.Pe_rest;
  } :: s.split t.var_e1 s.pref_e2 e.Pe_rest,
  {
    <IsVar e.Pe_rest> =
      e.Pe_rest ((e.Pe_rest) (s.dir <Gener_Len_Var e.Pe_rest>));
//      <Vars-Reset e.Pe-rest>;
    <Gener_Vars ((VAR)) s.pref_e2 t.var> : t.var_e2,
      t.var_e2 ((t.var_e2) (s.dir e.Pe_rest));
  } : t.var_e2 (e.clash),
  <Set_Var ("Instantiated?" True) t.var_e1>,
  <Set_Var ("Instantiated?" True) t.var_e2>,
  <Store &Clashes <Compose_Clashes e.clash> e.rest>,
  <Get_Var Clashes t.var_e1> :: e.clashes,
  <Map &Reclassify_Clash (<List.Sub (e.clashes) <Get &Checked_Lengths>>)> : e,
  s.split (e.left) (e.right) (e.len) t.var t.var_e1 t.var_e2;




$func Ref_Len t.name = e.length;

/*
 * Из верхнего уровня выражения изымаются все переменные, длина которых не
 * может быть посчитана (она неизвестна из формата, и переменная ещё не
 * получила значение в run-time).  Список этих переменных возвращается вторым
 * параметром.  Первым параметром возвращается длина оставшегося после их
 * изъятия выражения.
 */
Get_Known_Length e.Re =
  e.Re (/*e.length*/) (/*e.unknown-vars*/) $iter {
    e.Re : t.Rt e.rest, t.Rt : {
      s.ObjectSymbol = 1 ();	// Может появиться из константы.
      (PAREN e) = 1 ();
      (FUNC e) = 1 ();
      ("FUNC?" e) = 1 ();
      (REF t.name) = <Ref_Len t.name> ();
      (STATIC t.name) = <Get_Known_Length <Get_Static t.Rt>>;
      t, <IsVar t.Rt>, {
        <Get_Var Length t.Rt> : v.len = v.len ();
        /*empty*/ (t.Rt);
      };
    } :: e.len (e.var),
      e.rest (e.length e.len) (e.unknown_vars e.var);
  } :: e.Re (e.length) (e.unknown_vars),
  e.Re : /*empty*/ =
  {
    e.length : /*empty*/ = 0 (e.unknown_vars);
    e.length (e.unknown_vars);
  };

$table Const_Len;  // Fixme: инициализировать когда?

Ref_Len t.name = {
  <Lookup &Const_Len t.name>;
  <Get_Known_Length <Middle 3 0 <Lookup &Const t.name>>> :: e.len t =
    <Bind &Const_Len (t.name) (e.len)>,
    e.len;
  1;
};