OberonCore

MODULE SacredTables;

IMPORT Views, Strings, Ports, Controls, Properties, Stores, Controllers, Fonts, Meta, Dialog
,StdLog;


TYPE
   String = POINTER TO ARRAY 256 OF CHAR;
   
   CellProperties* = RECORD (* оформление ячейки!!! *)
      alignX*,                      (* -1 влево, 0 по центру, 1 - вправо*)
      alignY*:INTEGER;    (* -1 вверх, 0 по центру, 1 - вниз *)
      color*, bkColor* : Ports.Color;
      font* : Fonts.Font;
   END;

   (* Это как для связи с данными, так и для оформления!!! *)
   TableData* = POINTER TO ABSTRACT RECORD
   END;
   
   TableDataContainer* = RECORD (* это чтобы Мету обмануть... *)
      realData* : TableData;
   END;
   
   TableValue = RECORD (Meta.Value) (* шо за магия такая??? *)
      table : TableDataContainer
   END;

   Control* = POINTER TO EXTENSIBLE RECORD (Controls.Control)
      origin*, (* сдвиг (прокрутка) *)
      fixed*, (* непрокручиваемых столбцов/колонок *)
      size* : Ports.Point; (* размер отображения *)
      cursor* : INTEGER; (* позиция курсора (выделенной строки) *)
   END;


   TableDataExample* = POINTER TO RECORD(TableData)
   END;

VAR
   test* : TableDataContainer; (* для диалога *)
   TE : TableDataExample;
   defaultCell : CellProperties;

PROCEDURE RoundedDIV(I1, I2 : INTEGER) : INTEGER;
VAR
   temp : INTEGER;
BEGIN
   temp := I1 DIV I2;
   IF ABS(I1-temp*I2)< ABS(I1-(temp+1)*I2) THEN
      RETURN temp
   ELSE
      RETURN temp+1
   END;
END RoundedDIV;


PROCEDURE (this:TableData) CellProperties* (colIndex, rowIndex : INTEGER; VAR properties: CellProperties), NEW, EXTENSIBLE;
BEGIN
   IF rowIndex=-1 THEN
      properties.alignX := 0;
   ELSE
      properties.alignX := 1;
   END;
   properties.alignY := 0;
   IF (rowIndex <0) OR (colIndex < 0) THEN
      properties.bkColor := Ports.grey12;
   END;
END CellProperties;

PROCEDURE (this:TableData) RowHeight* (rowIndex:INTEGER):INTEGER, NEW, EXTENSIBLE;
BEGIN
   RETURN 3*Ports.mm
END RowHeight;

PROCEDURE (this:TableData) ColWidth* (colIndex:INTEGER):INTEGER, NEW, EXTENSIBLE;
BEGIN
   RETURN 20*Ports.mm
END ColWidth;

PROCEDURE (this:TableData) RowCount*():INTEGER, NEW, EXTENSIBLE;
BEGIN
   RETURN 14 (* не считая заголовков*)
END RowCount;

PROCEDURE (this:TableData) ColCount* ():INTEGER, NEW, EXTENSIBLE;
BEGIN
   RETURN 13 (* не считая заголовков*)
END ColCount;

PROCEDURE (this:TableData) Item* (ColIndex, RowIndex:INTEGER; OUT Str : ARRAY OF CHAR), NEW, ABSTRACT;



PROCEDURE (this:Control) GetRealData* ():TableData, NEW;
VAR
   ok : BOOLEAN;
   data : TableValue;
BEGIN
   IF this.item.Valid() THEN
      this.item.GetVal(data, ok);
   ELSE
      ok := FALSE;
   END;
   IF ok & (data.table.realData#NIL) THEN
      RETURN data.table.realData
   ELSE
      RETURN NIL
   END;
END GetRealData;

PROCEDURE (this:Control) Width* ():INTEGER, NEW; (* полная ширина всей таблицы *)
VAR
   i, w: INTEGER;
   data : TableData;
BEGIN
   w:=0;
   data := this.GetRealData();
   IF data # NIL THEN
      FOR i:=-1 TO data.ColCount()-1 DO
         INC(w, data.ColWidth(i))
      END;
   END;
   RETURN w
END Width;

PROCEDURE (this:Control) GetHeight* ():INTEGER, NEW;  (* полная высота всей таблицы *)
VAR
   i, h: INTEGER;
   data : TableData;
BEGIN
   h:=0;
   data := this.GetRealData();
   IF data # NIL THEN
      FOR i:=-1 TO data.RowCount()-1 DO
         INC(h, data.RowHeight(i))
      END;
   END;
   RETURN h
END GetHeight;


PROCEDURE (this:Control) OriginWidth* ():INTEGER, NEW; (* ширина сдвинутой части таблицы *)
VAR
   i, w: INTEGER;
   data : TableData;
BEGIN
   w:=0;
   data := this.GetRealData();
   IF data # NIL THEN
      FOR i:=this.fixed.x TO this.fixed.x+this.origin.x-1 DO
         INC(w, data.ColWidth(i))
      END;
   END;
   RETURN w
END OriginWidth;

 (* высота сдвинутой части таблицы *)
PROCEDURE (this:Control) OriginHeight* ():INTEGER, NEW;
VAR
   data : TableData;
BEGIN
   data := this.GetRealData();
   IF data # NIL THEN
      RETURN this.origin.y-1 - this.fixed.y;
   END;
   RETURN 0
END OriginHeight;


PROCEDURE (v: Control)  ScrolledRowsOnPage():INTEGER, NEW;
VAR
   w, h, y, height, rowInd, res, rowCount : INTEGER;
   data : TableData;
BEGIN
   data := v.GetRealData();
   res := 0;
   IF data # NIL THEN
      v.context.GetSize(w, h);
      rowInd := -1; (*v.Origin.y;*)
      y := data.RowHeight(rowInd); (* t *)
      rowCount := data.RowCount();
      WHILE (y < h) & (rowInd < rowCount) DO
         IF rowInd >= v.origin.y+v.fixed.y THEN
            INC(res); (* добавляем строчку *)
         END;
         INC(rowInd);
         IF rowInd = v.fixed.y THEN (* отобразили все непрокручиваемые *)
            INC(rowInd, v.origin.y);
         END;
         height := data.RowHeight(rowInd);
         INC(y, height);
      END;
   END;
   RETURN res
END ScrolledRowsOnPage;

PROCEDURE (v: Control)  Restore* (f: Views.Frame; l, t, r, b: INTEGER);
(* SacredTables ForexMain Fonts Views*)
VAR
   rowInd, colInd, (* индексы текущей ячейки *)
   x, y,                (* расположение левого верхнего угла текущей ячейки *)
   xStr, yStr, (* позиция вывода строки с учётом выравнивания *)
   width, height : INTEGER;  (* ширина и высота текущей ячейки *)
   rowCount, colCount : INTEGER; (* число строк и колонок. Кэш-переменные, для ускорения*)
   data : TableData;
   otstup : INTEGER;
   str : ARRAY 100 OF CHAR;
   strWidth, (* ширина строки *)
   strHeight, asc, dsc : INTEGER; (* высота строки *)
   properties : CellProperties; (* оформление ячейки *)
BEGIN
(*l, t, r, b -  Это не границы отображения, это - границы той части, которую надо перерисовать!!! *)
   otstup := 2 * Ports.mm DIV 10;
   data := v.GetRealData();
   defaultCell.font.GetBounds(asc, dsc, strWidth);
   strHeight := asc-dsc;
   IF data = NIL THEN
      str := "No data";
      strWidth := defaultCell.font.StringWidth(str$);
      width := f.r-f.l; (*  ширина контрола*)
      height := f.b-f.t; (* высота контрола *)
      xStr := (width - strWidth) DIV 2;
      yStr := (height + strHeight) DIV 2;
      f.DrawString(xStr, yStr, defaultCell.color, str$, defaultCell.font);
      RETURN
   END;
   rowCount := data.RowCount();
   colCount := data.ColCount();
   rowInd := -1; (*v.Origin.y;*)
   y := 0; (* t *)
   f.DrawRect(l, t, r, b, Ports.fill, defaultCell.bkColor); (* зальём всю область *)
   WHILE (y < b) & (rowInd < rowCount) DO
      height := data.RowHeight(rowInd);
      IF y+height > t THEN
         colInd := -1; (*v.Origin.x;*)
         x := 0; (* l *)
         f.DrawLine(x, y, x+width, y, f.dot, Ports.grey25); (**)
         WHILE (x < r) & (colInd < colCount) DO
            width := data.ColWidth(colInd);
            IF x+width > l THEN
               properties := defaultCell;
               data.CellProperties(colInd, rowInd, properties);
               data.Item(colInd, rowInd, str);
               
               IF defaultCell.bkColor#properties.bkColor THEN (* перекрасим, только если надо *)
                  f.DrawRect(x, y, x+width, y+height, Ports.fill, properties.bkColor);
(*               f.DrawRect(x, y, x+width, y+height, f.dot, Ports.black);*)
               END;
(*  с выравниванием по высоте не так просто... *)               
               properties.font.GetBounds(asc, dsc, strWidth);
               strHeight := asc-dsc;
               CASE properties.alignY OF
               -1: yStr := y+strHeight+otstup;
               |0: yStr := y+(height+strHeight) DIV 2+otstup;
               |1: yStr := y+height-otstup;
               END;
               strWidth := properties.font.StringWidth(str);
               CASE properties.alignX OF
               -1: xStr := x+otstup;
               |0: xStr := x + (width - strWidth) DIV 2;
               |1: xStr := x + width - strWidth-otstup;
               END;
               f.DrawString(xStr, yStr, properties.color, str, properties.font);
            END; (* IF *)
            INC(colInd);
            IF colInd = v.fixed.x THEN (* отобразили все непрокручиваемые *)
               INC(colInd, v.origin.x);
            END;
            IF y + height >= b THEN (* это последняя строчка *)
(* рисуем линии слева *)
               f.DrawLine(x, MIN(t, y + height), x, MIN(b, y + height), f.dot, Ports.grey25); (* вертикаль слева*)
(* а если это самый правый то и справа *)
               IF colInd = colCount THEN (* вертикаль справа*)
                  f.DrawLine(x+width, MIN(t, y + height), x+width, MIN(b, y + height), f.dot, Ports.grey25);
               END;
            END;   
            x := x + width;
         END; (* цикл по столбцам (Х) *)
(* нарисуем горизонтали *)         
         f.DrawLine(MIN(l, x), y, MIN(r, x), y, f.dot, Ports.grey25); (* горизонталь сверху *)
(* а если это самый нижний то и снизу *)
         IF rowInd = rowCount-1 THEN (* горизонталь снизу *)
            f.DrawLine(MIN(l, x), y+height, MIN(r, x), y+height, f.dot, Ports.grey25);
         END;
      END; (* IF *)
      INC(rowInd);
      IF rowInd = v.fixed.y THEN (* отобразили все непрокручиваемые *)
         INC(rowInd, v.origin.y);
      END;
      y := y + height;
   END; (* цикл по строкам (Y) *)
END Restore;


PROCEDURE (v: Control) Internalize2- (VAR rd: Stores.Reader);
   VAR version: INTEGER;
BEGIN
   rd.ReadVersion(0, 1, version);
   IF ~rd.cancelled THEN
      rd.ReadInt(v.origin.y);
      rd.ReadInt(v.origin.x);
      rd.ReadInt(v.fixed.y);
      rd.ReadInt(v.fixed.x);
   END
END Internalize2;

PROCEDURE (v: Control) Externalize2- (VAR wr: Stores.Writer);
BEGIN
   wr.WriteVersion(0);
   wr.WriteInt(v.origin.y);
   wr.WriteInt(v.origin.x);
   wr.WriteInt(v.fixed.y);
   wr.WriteInt(v.fixed.x);
END Externalize2;

PROCEDURE (v: Control) CopyFromSimpleView2- (source: Controls.Control);
BEGIN
   WITH source: Control DO
      v.origin.y := source.origin.y;
      v.origin.x := source.origin.x;
      v.fixed.y := source.fixed.y;
      v.fixed.x := source.fixed.x;
   END
END CopyFromSimpleView2;

PROCEDURE (v: Control) HandlePropMsg2- (VAR msg: Properties.Message);
   VAR
      sizeProp: Properties.SizeProp;
      prop: Properties.Property;
BEGIN
   WITH msg: Properties.SizePref DO
      IF (msg.w = Views.undefined) OR (msg.h = Views.undefined) THEN
         msg.w := v.size.x;
         msg.h := v.size.y (* размеры по-умолчанию *)
      END
(*   | msg: Properties.ResizePref DO
      msg.horFitToWin := TRUE;
      msg.verFitToWin := TRUE *)
   | msg: Properties.FocusPref DO
      msg.setFocus := TRUE (* обязательно, иначе прокрутки не будет!!! *)
   | msg: Properties.PollMsg DO
      NEW(sizeProp);
      sizeProp.width := v.size.x;
      sizeProp.height := v.size.y;
      sizeProp.valid := {Properties.size};
      sizeProp.known := {Properties.size};
      Properties.Insert(msg.prop, sizeProp)
   | msg: Properties.SetMsg DO
      prop := msg.prop;
      WHILE prop # NIL DO
         WITH prop: Properties.SizeProp DO
            IF Properties.size IN prop.valid THEN v.size.x := prop.width; v.size.y := prop.height; END
         ELSE
         END;
         prop := prop.next
      END;
      Views.Update(v, Views.keepFrames)

   ELSE   (* игнорировать другие сообщения *)
   END
END HandlePropMsg2;

PROCEDURE (v: Control) HandleCtrlMsg2- (f: Views.Frame;
                        VAR msg: Controllers.Message; VAR focus: Views.View);
VAR
   w, h : INTEGER;
   changed : BOOLEAN;
   data : TableData;
   colCount, rowCount : INTEGER;
BEGIN
   data := v.GetRealData();
   IF data = NIL THEN
      RETURN
   END;
   colCount := data.ColCount();
   rowCount := data.RowCount();
   changed := TRUE; (* временно *)
   WITH msg: Controllers.ScrollMsg DO
      v.context.GetSize(w, h); (* получаем текущий размер *)
      IF msg.vertical THEN
         CASE msg.op OF
            Controllers.decLine: IF v.origin.y>0 THEN DEC(v.origin.y); END;
            |Controllers.incLine: IF v.origin.y+ v.ScrolledRowsOnPage() < rowCount THEN INC(v.origin.y); END;
            |Controllers.decPage: IF v.origin.y>0 THEN DEC(v.origin.y, v.ScrolledRowsOnPage());
               v.origin.y := MAX(v.origin.y, 0)  END;
            |Controllers.incPage: IF v.origin.y+ v.ScrolledRowsOnPage() < rowCount THEN INC(v.origin.y, v.ScrolledRowsOnPage()); END;
            |Controllers.gotoPos: v.origin.y := msg.pos;
         END;
      ELSE
         CASE msg.op OF
            Controllers.decLine: IF v.origin.x>0 THEN DEC(v.origin.x); END;
            |Controllers.incLine: IF v.OriginWidth()+w<v.Width() THEN INC(v.origin.x); END;
            |Controllers.decPage: IF v.origin.x>0 THEN DEC(v.origin.x); END;
            |Controllers.incPage: IF v.origin.x<colCount THEN INC(v.origin.x); END;
            |Controllers.gotoPos: v.origin.x := RoundedDIV(msg.pos, data.ColWidth(-1));
         END;
      END;
      msg.done := TRUE;
      IF changed THEN Views.Update(v, Views.keepFrames) END
   | msg: Controllers.PollSectionMsg DO (* определяем необходимость и параметры прокрутки *)
      v.context.GetSize(w, h); (* получаем текущий размер *)
      IF msg.vertical THEN
         msg.wholeSize := rowCount;
(*         StdLog.Int(v.Height()); *)
         msg.partSize := v.ScrolledRowsOnPage();
         msg.partPos := v.origin.y;
      ELSE
         msg.wholeSize := v.Width();
         msg.partSize := w;
         msg.partPos := v.OriginWidth();
      END;
      
      msg.valid := msg.partSize < msg.wholeSize;
      msg.done := TRUE
   ELSE
   END;
END HandleCtrlMsg2;

PROCEDURE (c: Control) CheckLink- (VAR ok: BOOLEAN);
   VAR item: Meta.Item; mod: Meta.Name; name: Meta.Name;
BEGIN
   item := c.item; ok := TRUE;
   IF (item.typ = Meta.recTyp) THEN
      item.GetTypeName(mod, name);
      IF (mod = "SacredTables") & (name = "TableDataContainer") THEN
         ok := TRUE
      ELSE
         ok := FALSE 
      END
   ELSE ok := FALSE
   END
END CheckLink;

PROCEDURE (c: Control) Update- (f: Views.Frame; op, from, to: INTEGER);
BEGIN
   Views.Update(c, Views.keepFrames)
END Update;


PROCEDURE (this:TableDataExample) Item* (colIndex, rowIndex:INTEGER; OUT str : ARRAY OF CHAR);
BEGIN
   ASSERT(rowIndex>=-1);   ASSERT(rowIndex<this.RowCount());
   ASSERT(colIndex>=-1);   ASSERT(colIndex<this.ColCount());
   IF colIndex=-1 THEN
      Strings.IntToString(rowIndex, str);
   ELSIF rowIndex=-1 THEN
      Strings.IntToString(colIndex, str);
   ELSE
      Strings.IntToString(colIndex*rowIndex, str);
   END;
END Item;

(*

PROCEDURE (c: Control) HandleViewMsg2- (f: Views.Frame; VAR msg: Views.Message);
BEGIN
   Views.Update(c, Views.rebuildFrames);
END HandleViewMsg2;


PROCEDURE (c: Control) UpdateList- (f: Views.Frame);
BEGIN
END UpdateList;

*)

PROCEDURE Deposit*;
   VAR v: Control;
BEGIN
   NEW(v);
   Views.Deposit(v)
END Deposit;

   
PROCEDURE DepositControl*;
   VAR
      p: Controls.Prop;
      c: Control;
BEGIN
   NEW(p);
   p.link := ""; p.label := ""; p.guard := ""; p.notifier := "";
   p.level := 0; p.opt[Controls.sorted] := FALSE;
   NEW(c);
   Controls.OpenLink(c, p);
   c.size.x := 62 * Ports.mm;
   c.size.y := 18 * Ports.mm; (* размеры по-умолчанию *)
   Views.Deposit(c)
END DepositControl;

PROCEDURE Link*;
BEGIN
   NEW(TE);
   test.realData := TE;
   Dialog.Update(test);
END Link;

BEGIN
   defaultCell.alignX := -1; (* -1 влево, 0 по центру, 1 - вправо*)
   defaultCell.alignY := 0; (* -1 вверх, 0 по центру, 1 - вниз*)
   defaultCell.color := Ports.black;
   defaultCell.bkColor := Ports.white;
   defaultCell.font := Fonts.dir.Default();
END SacredTables.

 :commander:  "SacredTables.Deposit; StdCmds.Open"

 :commander: "SacredTables.DepositControl;StdCmds.PasteView;StdCmds.PasteViewGuard"

StdCoder.Decode I3aMgJqQIJqQotmPYB4.,0 1Ak...uD....58FTuPE,5TWyqlKrqKKrGrtu
 mdGLmGorCquU2hgnRAXDFTvMUn7FTvMf1G2sETfPdPMHfP9fQbf9hOO9vR7ONbvMoedhgrRiio
 edFWUkTeoxhmhgnpZHZijJC7ONbvM0.,.S.Sr,E.0k,5TWyql.bnayKmKKqGomC5XzET1.PuP.
 MHT9N9ntumaU2,CJuyKtQC98P9PP7ONbXmb.2.gs0k2kS9.,E.cUOor8rqOpoKantId9NhOO9v
 R704TXyKt.bHfEWUmL.6..D.Df.E.Cc4xhmNHT9NQCbWBxhYhA704D.CbB,708T1U.Ey4.J.dP
 .2U.2.IEb8R7vI5fQT9PNPNZvQRdJ.0U1U.2.4AS.a80E.IE4ql8rmGKe4KlmqmCLLCoruKu8r
 rmKWKqtMw50sQRtET1Y6cwE.0..272.7sI4aXdQKaY7J,MM8agNNCbi6RK4G50......VuI3.,
 6.EUvEF2cXD,zF.2kmI.,O41EU4IG2kwL,3Qw5uPR1CbEhin3h0hioZijph2hgnRAZz16.,UMV
 .U.F.6,AA...o3NmooBL1Nmo.2U...6UpO7gg26cd7AWzkTU.G..3IXkVyKrUgViQeotETfPd1
 6F9vQ0ksP2.UnpZ1xB.G20U1VV,.Z1...bf9.EWE.8T0E...H.0U0.,c.16QBa.BX,M,2.,k.m
 Ew71lbAqwr6nLv78ssH2.C2..C,2..600U..N6.,E.0ohCL.AnW8Utj00My7kx8O0MCT7Hb...
 .
 --- end of encoding ---