(**********************************************************************

    :Program.  	 SuperLists.mod
    :Contents.	 Text-list Playfield handler
    :Author.   	 Nicolas Benezan [bne]
    :Address.    Postwiesenstr. 2, D7000 Stuttgart 60
    :Phone.      711/333679
    :Copyright.  Public Domain
    :Language. 	 Modula-II
    :Translator. M2Amiga AMSoft
    :History.    V1.0b [bne] 28.05.88 (first PD-version Amok#1)
    :History.    V1.1a [bne] 10.06.88 (extended MemHandler)
    :History.	 + VAR AllocProc,DeallocProc
    :History.    V1.2g [bne] 21.07.88 ("VertFree-only" also available)
    :History.	 InsertEntry, RemoveEntry, ClickRow Bugs corrected
    :History.	 V1.3a [bne] 14.08.88 (MakeExtEntry, ClearList)
    
**********************************************************************)

IMPLEMENTATION MODULE SuperLists;

FROM Exec	IMPORT Node,List,NodePtr,AddHead,AddTail,Insert,Remove,
		Byte,UByte,NodeType,CopyMem;
FROM Intuition	IMPORT GadgetPtr,Gadget,PropInfo,maxPot,maxBody,
		ModifyProp,PropInfoPtr,WindowPtr,RequesterPtr,
                PropInfoFlagSet;
FROM Graphics	IMPORT DrawModeSet,RastPortPtr,Move,Text,SetAPen,SetBPen,
		SetDrMd,RectFill,ScrollRaster;
FROM Arts	IMPORT Assert,Error;
FROM SYSTEM	IMPORT BITSET,ADDRESS,ADR,CAST;

CONST	ErrorHeader="Modula SuperLists:";
	AllocError="No AllocProc installed";
	DeallocError="No DeallocProc installed";
        CantRethink="RethinkList: Illegal parameters";

PROCEDURE FailAlloc(VAR DummyA:ADDRESS;DummyL:LONGINT);
BEGIN
  Error(ADR(ErrorHeader),ADR(AllocError));
END FailAlloc;

PROCEDURE FailDealloc(VAR DummyA:ADDRESS);
BEGIN
  Error(ADR(ErrorHeader),ADR(DeallocError));
END FailDealloc;

PROCEDURE ScanList(node:NodePtr;Step:INTEGER):NodePtr;
BEGIN
  IF node^.succ#NIL THEN
    WHILE (node^.succ^.succ#NIL)AND(Step#0) DO
      node:=node^.succ;
      DEC(Step);
    END;
    RETURN node;
  ELSE
    RETURN node^.pred;
  END;
END ScanList;

PROCEDURE GetLen(text:ADDRESS;VAR Len:INTEGER);
CONST	nul=CHAR(0);
VAR	CharPtr:POINTER TO CHAR;
BEGIN
  Len:=0;
  CharPtr:=text;
  WHILE (CharPtr^#nul)AND(Len<255) DO
    INC(CharPtr);
    INC(Len);
  END;
END GetLen;

PROCEDURE SetLen(node:NodePtr;VAR MaxLen:INTEGER);
VAR	Len:INTEGER;
BEGIN
  WITH node^ DO
    GetLen(name,Len);
    IF MaxLen<Len THEN
      MaxLen:=Len;
    END;
    pri:=Len;
  END;
END SetLen;

PROCEDURE RethinkList(List:SuperListPtr;New:BOOLEAN);
VAR	node:NodePtr;
BEGIN
  WITH List^ DO
    Assert((FontXsize>0)AND(FontYsize>0)AND(height>=FontYsize)
      AND(width>FontXsize),ADR(CantRethink));
    effWidth:=(width-1) DIV FontXsize;
    effHeight:=(height-1) DIV FontYsize;
    IF New THEN
      node:=list.head;
      rows:=0;
      columns:=0;
      WHILE node^.succ#NIL DO
        SetLen(node,columns);
        INC(rows);
        node:=node^.succ;
      END;
    END;
    IF dispRow+effHeight>rows THEN
      dispRow:=rows-effHeight;
    END;
    IF dispRow<0 THEN
      dispRow:=0;
    END;
    IF dispColumn+effWidth>columns THEN
      dispColumn:=columns-effWidth;
    END;
    IF dispColumn<0 THEN
      dispColumn:=0;
    END;
    topEntry:=ScanList(list.head,dispRow);
    bottomEntry:=ScanList(topEntry,effHeight-1);
  END;
END RethinkList;

PROCEDURE WriteEntry(List:SuperListPtr;entry:EntryPtr;Line:INTEGER);
VAR	text:ADDRESS;
	Len:INTEGER;
BEGIN
  WITH List^ DO
    Move(rastPort,leftEdge+1,topEdge+Line*FontYsize+FontBaseLine);
    WITH entry^ DO
      text:=node.name+LONGINT(dispColumn);
      Len:=node.pri-dispColumn;
      IF Len>effWidth THEN
        Len:=effWidth;
      END;
      IF Len>0 THEN
        SetAPen(rastPort,frontPen);
        SetBPen(rastPort,backPen);
        SetDrMd(rastPort,drawMode);
        Text(rastPort,text,Len);
      END;
    END;
  END;
END WriteEntry;

PROCEDURE RefreshList(List:SuperListPtr);
VAR	Num,Count:INTEGER;
	entry:NodePtr;
BEGIN
  RethinkList(List,oldList);
  WITH List^ DO
    SetAPen(rastPort,backPen);
    RectFill(rastPort,leftEdge,topEdge,leftEdge+width-1,topEdge+height-1);
    IF rows<effHeight THEN
      Num:=rows;
    ELSE
      Num:=effHeight;
    END;
    entry:=topEntry;
    FOR Count:=0 TO Num-1 DO
      WriteEntry(List,CAST(EntryPtr,entry),Count);
      entry:=ScanList(entry,1);
    END;
  END;
END RefreshList;

PROCEDURE RedrawEntry(List:SuperListPtr;Row:INTEGER);
VAR	Top:INTEGER;
BEGIN
  WITH List^ DO
    IF (Row<rows)AND(Row>=dispRow)AND(Row<dispRow+effHeight) THEN
      SetAPen(rastPort,backPen);
      Top:=topEdge+(Row-dispRow)*FontYsize;
      RectFill(rastPort,leftEdge,Top,leftEdge+width-1,Top+FontYsize-1);
      WriteEntry(List,CAST(EntryPtr,ScanList(topEntry,Row-dispRow)),
        Row-dispRow);
    END;
  END;
END RedrawEntry;

PROCEDURE RedrawColumn(List:SuperListPtr;Column:INTEGER);
VAR	xPos,yPos,Row:INTEGER;
	entry:EntryPtr;
BEGIN
  WITH List^ DO
    entry:=CAST(EntryPtr,topEntry);
    xPos:=leftEdge+1+Column*FontXsize;
    yPos:=topEdge+FontBaseLine;
    INC(Column,dispColumn);
    Row:=0;
    WHILE (Row<effHeight)AND(Row<rows) DO
      WITH entry^ DO
        IF node.pri>Column THEN
          SetAPen(rastPort,frontPen);
          SetBPen(rastPort,backPen);
          SetDrMd(rastPort,drawMode);
          Move(rastPort,xPos,yPos);
          Text(rastPort,node.name+LONGINT(Column),1);
        END;
        entry:=CAST(EntryPtr,node.succ); (* Don't adopt this style... *)
        (* don't change the WITH-statement's pointer within the 
           WITH-block itself *)
      END;
      INC(Row);
      INC(yPos,FontYsize);
    END;
  END;
END RedrawColumn;
        

PROCEDURE ScrollList(List:SuperListPtr;Dir:Directions);
VAR	TempPos:INTEGER;

BEGIN
  WITH List^ DO
    SetBPen(rastPort,backPen);
    CASE Dir OF
      Up: TempPos:=dispRow;
        DEC(dispRow);
        RethinkList(List,oldList);
        IF dispRow=TempPos-1 THEN
          ScrollRaster(rastPort,0,-FontYsize,
            leftEdge,topEdge,leftEdge+width-1,topEdge+FontYsize*effHeight-1);
          WriteEntry(List,CAST(EntryPtr,topEntry),0);
        END|
      Down: TempPos:=dispRow;
        INC(dispRow);
        RethinkList(List,oldList);
        IF dispRow=TempPos+1 THEN
          ScrollRaster(rastPort,0,FontYsize,
            leftEdge,topEdge,leftEdge+width-1,topEdge+height-1);
          WriteEntry(List,CAST(EntryPtr,bottomEntry),effHeight-1);
        END|
      Left: 
        IF propX#NIL THEN
          TempPos:=dispColumn;
          DEC(dispColumn);
          RethinkList(List,oldList);
          IF dispColumn=TempPos-1 THEN
            ScrollRaster(rastPort,-FontXsize,0,
              leftEdge,topEdge,leftEdge+FontXsize*effWidth,topEdge+height-1);
            RedrawColumn(List,0);
          END;
        END|
      Right:
        IF propX#NIL THEN
          TempPos:=dispColumn;
          INC(dispColumn);
          RethinkList(List,oldList);
          IF dispColumn=TempPos+1 THEN
            ScrollRaster(rastPort,FontXsize,0,
              leftEdge+1,topEdge,leftEdge+width-1,topEdge+height-1);
            RedrawColumn(List,effWidth-1);
          END;
        END;
    END;
  END;
END ScrollList;

PROCEDURE MakeExtEntry(text:ADDRESS;APen,BPen:INTEGER;
	Mode:DrawModeSet;Size:CARDINAL):ExtEntryPtr;
VAR	TextPtr:ADDRESS;
	NewEntry:EntryPtr;
        Len:INTEGER;
BEGIN
  Assert(Size>=SIZE(MinEntry),ADR("SuperLists: illegal ExtEntry size"));
  GetLen(text,Len);
  AllocProc(TextPtr,Len+1);
  IF TextPtr#NIL THEN
    AllocProc(NewEntry,Size);
    IF NewEntry#NIL THEN
      CopyMem(text,TextPtr,Len+1);
      WITH NewEntry^ DO
        WITH node DO
          succ:=NIL;
          pred:=NIL;
          type:=unknown;
          pri:=Len;
          name:=TextPtr;
        END;
        frontPen:=APen;
        backPen:=BPen;
        drawMode:=Mode;
      END;
      RETURN ADDRESS(NewEntry);
    ELSE
      DeallocProc(TextPtr);
    END;
  END;
  RETURN NIL;
END MakeExtEntry;

PROCEDURE MakeEntry(text:ADDRESS;APen,BPen:INTEGER;
	Mode:DrawModeSet):EntryPtr;
BEGIN
  RETURN MakeExtEntry(text,APen,BPen,Mode,SIZE(Entry));
END MakeEntry;

PROCEDURE GetEntry(List:SuperListPtr;Row:INTEGER):AnyEntryPtr;
BEGIN
  WITH List^ DO
    IF (Row>=0)AND(Row<rows) THEN
      IF Row<dispRow THEN
        RETURN CAST(EntryPtr,ScanList(list.head,Row));
      ELSE
        RETURN CAST(EntryPtr,ScanList(topEntry,Row-dispRow));
      END;
    ELSE
      RETURN NIL;
    END;
  END;
END GetEntry;

PROCEDURE InsertEntry(List:SuperListPtr;entry:AnyEntryPtr;Row:INTEGER;
	hidden:BOOLEAN);
VAR	SuccEntry:EntryPtr;
	node:NodePtr;
BEGIN
  WITH List^ DO
    INC(rows);
    IF (Row<0)OR(Row>=rows) THEN
      AddTail(ADR(list),CAST(NodePtr,entry));
      Row:=rows-1;
    ELSIF Row=0 THEN
      AddHead(ADR(list),CAST(NodePtr,entry));
    ELSE
      SuccEntry:=GetEntry(List,Row);
      node:=SuccEntry^.node.pred;
      Insert(ADR(list),CAST(NodePtr,entry),node);
    END;
    SetLen(CAST(NodePtr,entry),columns);
    IF (Row>=dispRow)AND(Row<dispRow+effHeight) THEN
      RethinkList(List,oldList);
      IF NOT hidden THEN
        SetBPen(rastPort,backPen);
        ScrollRaster(rastPort,0,-FontYsize,leftEdge,
          topEdge+(Row-dispRow)*FontYsize,leftEdge+width-1,
          topEdge+effHeight*FontYsize-1);
        RedrawEntry(List,Row);
      END;
    ELSIF Row<dispRow THEN
      INC(dispRow);
    END;
  END;
END InsertEntry;

PROCEDURE RemoveEntry(List:SuperListPtr;Row:INTEGER;VAR mustRethink:
	BOOLEAN;hidden,Dealloc:BOOLEAN);
VAR	entry:NodePtr;
BEGIN
  WITH List^ DO
    IF (Row<0)OR(Row>=rows) THEN
      Row:=rows-1;
    END;
    entry:=CAST(NodePtr,GetEntry(List,Row));
    IF entry#NIL THEN
      DEC(rows);
      IF entry^.pri=columns THEN
        mustRethink:=TRUE;
      END;
      Remove(entry);
      IF Dealloc THEN
        DeallocProc(entry^.name);
        DeallocProc(entry);
      END;
      IF (Row>=dispRow)AND(Row<dispRow+effHeight) THEN
        RethinkList(List,oldList);
        IF NOT hidden THEN
          SetBPen(rastPort,backPen);
          ScrollRaster(rastPort,0,FontYsize,leftEdge,
            topEdge+(Row-dispRow)*FontYsize,leftEdge+width-1,
            topEdge+effHeight*FontYsize-1);
          IF rows>=dispRow+effHeight THEN
            RedrawEntry(List,dispRow+effHeight-1);
          END;
        END;
      ELSIF Row<dispRow THEN
        DEC(dispRow);
      END;
    END;
  END;
END RemoveEntry;
    

PROCEDURE ClickRow(List:SuperListPtr;mouseX,mouseY:INTEGER):INTEGER;
VAR	Row:INTEGER;
BEGIN
  WITH List^ DO
    IF (mouseX>=leftEdge)AND(mouseX<leftEdge+width)AND
        (mouseY>=topEdge)AND(mouseY<topEdge+height) THEN
      Row:=(mouseY-topEdge)DIV FontYsize+dispRow;
      IF Row>=rows THEN
        RETURN -1
      ELSE
        RETURN Row;
      END;
    ELSE
      RETURN -1;
    END;
  END;
END ClickRow;

PROCEDURE GetProp(List:SuperListPtr);
VAR	Info:PropInfoPtr;
BEGIN
  WITH List^ DO
    IF (effWidth<columns)AND(propX#NIL) THEN
      Info:=propX^.specialInfo;
      WITH Info^ DO
        dispColumn:=(LONGINT(horizPot)*LONGINT(columns-effWidth))DIV maxPot;
      END;
    ELSE
      dispColumn:=0;
    END;
    IF effHeight<rows THEN
      Info:=propY^.specialInfo;
      WITH Info^ DO
        dispRow:=(LONGINT(vertPot)*LONGINT(rows-effHeight))DIV maxPot;
      END;
    ELSE
      dispRow:=0;
    END;
  END;
  RethinkList(List,oldList);
END GetProp;
    
PROCEDURE SetProp(List:SuperListPtr;Window:WindowPtr;Requester:
	RequesterPtr);
VAR	Pot,Body:CARDINAL;
	Info:PropInfoPtr;
        Flags:PropInfoFlagSet;
BEGIN
  WITH List^ DO
    IF propX#NIL THEN
      IF effWidth>=columns THEN
        Pot:=0;
        Body:=maxBody;
      ELSE
        Pot:=(LONGINT(dispColumn)*maxPot)DIV LONGINT(columns-effWidth);
        Body:=(LONGINT(effWidth)*maxBody)DIV LONGINT(columns);
      END;
      Info:=propX^.specialInfo;
      Flags:=Info^.flags;
      ModifyProp(propX,Window,Requester,Flags,
        Pot,0,Body,0);
    END;
    IF effHeight>=rows THEN
      Pot:=0;
      Body:=maxBody;
    ELSE
      Pot:=(LONGINT(dispRow)*maxPot)DIV LONGINT(rows-effHeight);
      Body:=(LONGINT(effHeight)*maxBody)DIV LONGINT(rows);
    END;
    Info:=propY^.specialInfo;
    Flags:=Info^.flags;
    ModifyProp(propY,Window,Requester,Flags,
      0,Pot,0,Body);
  END;
END SetProp;    

PROCEDURE ClearList(List:SuperListPtr;hidden:BOOLEAN);
VAR	Dummy:BOOLEAN;
BEGIN
  WHILE List^.rows>0 DO
    RemoveEntry(List,0,Dummy,hideIt,deallocIt);
  END;
  RethinkList(List,newList);
  IF NOT hidden THEN
    RefreshList(List);
  END;
END ClearList;

BEGIN
  AllocProc:=FailAlloc;
  DeallocProc:=FailDealloc;
END SuperLists.