Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/ECO30603.ZIP/ECO30603.LZH/ECOLIBBS/ECO_TEXT.PAS

Pascal/Delphi Source File | 1992-09-26 | 10.5 KB | 388 lines

(*
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓·──                                              ──·▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓│                                                  │░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   ECO_TEXT was Conceived, Designed and Written     ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   by Floor A.C. Naaijkens for                      ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   UltiHouse Software / The ECO Group.              ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓                                                    ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   (C) MCMXCII by EUROCON PANATIONAL CORPORATION.   ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   All Rights Reserved for The ECO Group.           ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓                                                    ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   Textbuffer interface (QHUD RHUD)                 ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓│                                                  │░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓·──                                              ──·░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
*)
unit eco_text;


{$A-,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V-}
{$M 65520, 0, 655360}



interface

type
  strptr = ^string;
  textnodeptr = ^textnode;
  textnode = record
    next,prev :textnodeptr; {line may not be made longer}
    line :strptr;   {allocation is length+1}
  end;
  textbuffer = record
    first,last :textnodeptr;
  end;

{-
  Note: Don't mess around inside the data structures defined above.
  Use the procedures to access them instead.  This unit should be
  written object orientated.  Some procedures don't use all their
  parameters at the moment.  This is intentional and will be useful
  if the structures are enhanced.
-}

{- initialise an empty buffer -}
procedure newbuffer(var t :textbuffer);

{- return true if the buffer is empty -}
function emptybuffer(var t :textbuffer) :boolean;

{- return a pointer to the first line of a buffer -}
function firstline(var t :textbuffer) :textnodeptr;

{- return a pointer to the last line of a buffer -}
function lastline(var t :textbuffer) :textnodeptr;

{- return the next line in a buffer -}
function nextline(var t :textbuffer;  pos :textnodeptr) :textnodeptr;

{- return the previous line in a buffer -}
function prevline(var t :textbuffer;  pos :textnodeptr) :textnodeptr;

{- add a line to the end of a buffer -}
procedure addtoend(var t :textbuffer;  line :string);

{- insert a line before another line -}
procedure addinsert(var t :textbuffer;  pos :textnodeptr;  line :string);

{- delete a line and return the next line or nil if it was the last line -}
function deleteline(var t :textbuffer;  var pos :textnodeptr) :textnodeptr;

{- delete a buffer -}
procedure deletebuffer(var t :textbuffer);

{- retrieve the text value from a line -}
function gettextline(var t: textbuffer;  pos :textnodeptr) :string;

{- assign a new string to a line of text -}
procedure modifytextline(var t: textbuffer;  pos :textnodeptr;  line :string);

{- word wrap the buffer -}
procedure wrapbuffer(var t :textbuffer;  margin :byte);

{- create a new buffer with maximum length (255) lines -}
procedure unwrapbuffer(var t,w :textbuffer);

{- count the number of lines in a buffer -}
function bufferlength(var t :textbuffer) :word;







implementation








  procedure newbuffer(var t :textbuffer);
  begin
    t.first := nil;
    t.last := nil;
  end; {newbuffer}


  procedure deletebuffer(var t :textbuffer);
  var step,temp :textnodeptr;
  begin
    step := t.first;
    while (step <> nil) do begin
      freemem(step^.line,length(step^.line^)+1);
      temp := step;
      step := step^.next;
      dispose(temp);
    end; {while}
    newbuffer(t);
  end; {deletebuffer}


  function emptybuffer(var t :textbuffer) :boolean;
  begin
    emptybuffer := (t.first = nil);
  end; {emptybuffer}


  function firstline(var t :textbuffer) :textnodeptr;
  begin
    firstline := t.first;
  end; {firstline}


  function lastline(var t :textbuffer) :textnodeptr;
  begin
    lastline := t.last;
  end; {lastline}


  function nextline(var t :textbuffer;  pos :textnodeptr) :textnodeptr;
  begin
    nextline := nil;
    if (pos = nil) then exit;
    nextline := pos^.next;
  end; {nextline}


  function prevline(var t :textbuffer;  pos :textnodeptr) :textnodeptr;
  begin
    prevline := nil;
    if (pos = nil) then exit;
    prevline := pos^.prev;
  end; {prevline}


  function deleteline(var t :textbuffer;  var pos :textnodeptr) :textnodeptr;
  begin
    deleteline := nextline(t,pos);
    if (pos=nil) or emptybuffer(t) then exit;
    if (pos^.prev <> nil) then pos^.prev^.next := pos^.next;
    if (pos^.next <> nil) then pos^.next^.prev := pos^.prev;
    if (pos = t.first) then t.first := pos^.next; {pos was first node}
    if (pos = t.last) then t.last := pos^.prev;   {pos was last node}
    if (pos^.line <> nil) then freemem(pos^.line,length(pos^.line^)+1);
                                                    {free existing line}
    dispose(pos); pos := nil;
  end;


  function newnode(line :string) :textnodeptr;
  var temp :textnodeptr;
  begin
    newnode := nil;
    new(temp);
    if (temp=nil) then exit;
    temp^.next := nil;
    temp^.prev := nil;
    getmem(temp^.line,length(line)+1);
    if (temp^.line = nil) then exit;
    temp^.line^ := line;
    newnode := temp;
  end; {newnode}


  procedure modifytextline(var t: textbuffer;  pos :textnodeptr;  line :string);
  begin
    if pos=nil then exit;
    if (pos^.line <> nil) then    {free existing line}
      freemem(pos^.line,length(pos^.line^)+1);
    getmem(pos^.line,length(line)+1); {space for new line}
    if (pos^.line = nil) then exit;
    pos^.line^ := line;
  end; {modifytextline}


  function gettextline(var t: textbuffer;  pos :textnodeptr) :string;
  begin
    gettextline := '';
    if pos=nil then exit;
    gettextline := pos^.line^;
  end; {gettextline}


  procedure addtoend(var t :textbuffer;  line :string);
  var temp :textnodeptr;
  begin
    temp := newnode(line);
    if (temp=nil) then exit;

    if (t.first = nil) then begin
      t.first := temp;
      t.last := t.first;
    end else begin
      t.last^.next := temp;
      temp^.prev := t.last;
      t.last := temp;
    end; {else}
  end; {addtoend}


  procedure addinsert(var t :textbuffer;  pos :textnodeptr;  line :string);
  var temp :textnodeptr;
  begin
    if (emptybuffer(t) or (pos = nil)) then begin
      addtoend(t,line);
    end else begin
      temp := newnode(line);
      if (temp=nil) then exit;

      if (pos^.prev <> nil) then
        pos^.prev^.next := temp;
      temp^.next := pos;
      temp^.prev := pos^.prev;
      pos^.prev := temp;

      if (pos = t.first) then   {new front}
        t.first := temp;
    end; {else}
  end; {addinsert}


  function bufferlength(var t :textbuffer) :word;
  var
    count :word;
    step :textnodeptr;
  begin
    count := 0;
    step := t.first;
    while (step <> nil) do begin
      step := step^.next;
      inc(count);
    end; {while}

    bufferlength := count;
  end; {bufferlength}

  {- Create a new, wrapped, buffer.  Margin must be reasonable, i.e. not too
   close to 0 or 255 -}


  procedure wrapbuffer(var t :textbuffer;  margin :byte);
  const seperators = [#32..#47,#58..#64,#91..#96,#123..#126];
  var
    w :textbuffer;
    line :string;
    source :word; {can't be Byte, Length may be 255}
    step :textnodeptr;
    ch :char;

    procedure finishline;
    begin
      addtoend(w,line);
      line := '';
    end; {finishline}


    procedure addchar(ch :char);
    var
      overflow :string;
      p :byte;
    begin
      if (length(line) >= margin) then begin  {break the line}
        overflow := '';
          {first remove excess spaces}
        if (line[length(line)]=' ') then
          while (length(line) > 1) and (line[length(line)-1]=' ') do
            dec(line[0]);     {drop last space}

        if (length(line) >= margin) then begin
          p := length(line);
          while (p > 0) and not (line[p] in seperators) do
            dec(p);       {look backwards for seperator}

          if (p=0) then p := margin;    {no seperator, one huge word}

          overflow := copy(line,p+1,length(line)-p);
          line[0] := char(p);
        end; {if}

        finishline;
        line := overflow+ch;
      end else begin
        line := line+ch;
      end; {else}
    end; {addchar}


    procedure tab;
    var count :byte;
    begin
      for count := 1 to 8-((length(line)-1) mod 8) do addchar(' ');
    end; {tab}

  begin
    newbuffer(w);
    step := t.first; line := '';
    while (step <> nil) do begin
      source := 1;
      while (source <= length(step^.line^)) do begin
        ch := step^.line^[source];
        case ch of
          ^m : begin
            line := line+^m^j;
            finishline;
          end;
          ^i : tab;
          ^j,#141 : {ignore lf and soft-cr};
          else addchar(ch);
        end; {case}
        inc(source);
      end; {while}
      step := step^.next;
    end; {while}
    if (line <> '') then finishline;
    deletebuffer(t);
    t := w;
  end; {wrapbuffer}


  {- Create a new, unwrapped, buffer.  All the lines except the last one
   in the new buffer will be of length 255 -}


  procedure unwrapbuffer(var t,w :textbuffer);
  var
    line :string;
    source :word; {can't be Byte, Length may be 255}
    step :textnodeptr;


    procedure finishline;
    begin
      addtoend(w,line);
      line := '';
    end; {finishline}


    procedure addchar(ch :char);
    begin
      if (length(line) = 255) then finishline;
      line := line+ch;
    end; {addchar}


  begin
    newbuffer(w); step := t.first; line := '';
    while (step <> nil) do begin
      for source := 1 to length(step^.line^) do addchar(step^.line^[source]);
      step := step^.next;
    end; {while}
    if (line <> '') then finishline;
  end; {unwrapbuffer}



end. quickbbs message text, credits to p.j. muller