POINT Software Programming/PPROG1.ISO/pascal/swag/textedit.swg/0004_GHOSTED.PAS.pas

Pascal/Delphi Source File | 1993-05-28 | 9.8 KB | 398 lines

TR>Can anyone (please, it's important) , post here an example of a source code
TR>that will show a text file , and let me scroll it (Up , Down ) ?
TR>Also I need an example of a simple editor.

Try this for an example. Turbo Pascal 6.0+ source.
Compiles to a 7K text editor. Neat?

{$A-,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S-,V-,X+}
{$M $C00,0,0}
program ghostEd; {Ghost Editor v0.4 (C) 1993 Sean L. Palmer}
const
 version='0.4';
 maxF=$3FFF;     {only handles small files!}
 txtColor=$B;
 vSeg:word=$B800;
var
 nLines:byte;
 halfPage:byte;
 txt:array[0..maxF]of char;
 crs,endF,pgBase,lnBase:integer;
 x,y:word;
 update:boolean;
 theFile:file;
 ticks:word absolute $40:$6C;   {ticks happen 18.2 times/second}

procedure syncTick;var i:word;begin i:=ticks;repeat until i<>ticks;end;

function readKey:char;assembler;asm mov ah,$07; int $21; end;

function keyPressed:boolean;assembler;asm mov ah,$B; int $21; and al,$FE;
end;

procedure moveScrUp(s,d,n:word);assembler;asm
 mov cx,n;
 push ds;
 mov ax,vSeg; mov es,ax; mov ds,ax;
 mov si,s; shl si,1;
 mov di,d; shl di,1;
 cld; repz movsw; {attr too!}
 pop ds; @X:
 end;

procedure moveScrDn(s,d,n:word);assembler;asm
 mov cx,n;
 push ds;
 mov ax,vSeg; mov es,ax; mov ds,ax;
 mov si,s; add si,cx; shl si,1;
 mov di,d; add di,cx; shl di,1;
 std; repz movsw; {attr too!}
 pop ds; @X:
 end;

procedure moveScr(var s;d,n:word);assembler;asm
 mov cx,n; jcxz @X;
 push ds;
 mov ax,vSeg; mov es,ax;
 mov di,d; shl di,1;
 lds si,s;
 cld;
@L: movsb; inc di; loop @L;
 pop ds; @X:
 end;

procedure fillScr(d,n:word;c:char);assembler;asm
 mov cx,n; jcxz @X;
 mov ax,vSeg; mov es,ax;
 mov di,d; shl di,1;
 mov al,c; cld;
@L: stosb; inc di; loop @L;
@X:
 end;

procedure fillAttr(d,n:word;c:byte);assembler;asm
 mov cx,n; jcxz @X;
 mov ax,vSeg; mov es,ax;
 mov di,d; shl di,1;
 mov al,c; cld;
@L: inc di; stosb; loop @L;
@X:
 end;

procedure cls;begin
 fillAttr(80,pred(nLines)*80,txtColor);
 fillScr(80,pred(nLines)*80,' ');
 end;

procedure scrollUp;begin
 moveScrUp(320,160,pred(nLines)*160);
 fillScr(pred(nLines)*160,80,' ');
 end;
procedure scrollDn;begin
 moveScrDn(160,320,pred(nLines)*320);
 fillScr(160,80,' ');
 end;

{put cursor after preceding CR or at 0}
function scanCrUp(i:integer):integer;assembler;asm
 mov di,i; mov cx,di; add di,offset txt
 mov ax,ds; mov es,ax;
 std; mov al,$D;
 dec di;
 repnz scasb;
 jnz @S; inc di; @S:
 inc di;
 sub di,offset txt;
 mov ax,di;
 end;

{put cursor on next CR or endF}
function scanCrDn(i:integer):integer;assembler;asm
 mov di,i; mov cx,endF;
 sub cx,di; inc cx; add di,offset txt;
 mov ax,ds; mov es,ax;
 cld; mov al,$D;
 repnz scasb;
 dec di;
 sub di,offset txt;
 mov ax,di;
 end;

procedure findxy;begin
 lnBase:=scanCrUp(crs);x:=crs-lnBase;
 y:=1;pgBase:=lnBase;
 while(pgBase>0)and(y<halfPage) do begin
  pgBase:=scanCrUp(pred(pgBase)); inc(y);
  end;
 end;

procedure display;var i,j,k,oldY:integer;begin
 findXY;
 if update then begin
  update:=false;
  j:=pgBase;i:=1;
  while (j<=endf) and (i<pred(nLines)) do begin
   k:=scanCrDn(j);
   moveScr(txt[j],i*80,k-j);
   fillScr(i*80+k-j,80-k+j,' ');
   fillAttr(i*80,80,txtColor);
   j:=succ(k); inc(i);
   end;
  if i<pred(nLines) then begin
   fillScr(i*80,80*pred(nLines-i),'X');
   fillAttr(i*80,80*pred(nLines-i),1);
   end;
  end
 else begin
>>> Continued to next message

 * OLX 2.2 * "Could you continue your petty bickering? I find it most

--- Maximus 2.01wb
 * Origin: >>> Sun Mountain BBS <<< (303)-665-6922 (1:104/123)

>>> Continued from previous message
  i:=scanCrDn(lnBase)-lnBase;
  moveScr(txt[lnBase],y*80,i);
  fillScr(y*80+i,80-i,' ');
  end;
 end;

const menuStr:string='Ghost Editor v'+version+'-(C) Sean Palmer 1993';
procedure title;begin
 fillAttr(0,80,$70);fillScr(0,80,' ');
 MoveScr(MenuStr[1],1,length(MenuStr));
 end;

procedure error(s:string);begin
 fillattr(0,80,$CE);fillScr(0,80,' ');
 moveScr(s[1],1,length(s));
 write(^G);readkey;
 title;
 end;

procedure tooBigErr;begin error('File too big');end;

procedure insChar(c:char);forward;
procedure delChar;forward;
procedure backChar;forward;

procedure trimLine;var i,t,b:integer;begin
 i:=crs;
 b:=scanCrDn(crs); t:=scanCrUp(crs);
 crs:=b;
 while txt[crs]=' ' do begin
  delchar;
  if i>crs then dec(i);
  if crs>0 then dec(crs);
  end;
 crs:=i;
 end;

procedure checkWrap(c:integer);var i,t,b:integer;begin
 b:=scanCrDn(c); t:=scanCrUp(c);
 i:=b;
 if i-t>=79 then begin
  i:=t+79;
  repeat dec(i); until (txt[i]=' ')or(i=t);
  if i=t then backChar   {just disallow lines that long with no spaces}
  else begin
   txt[i]:=^M;  {change sp into cr, to wrap}
   update:=true;
   if (b<endF)and(txt[b]=^M)and(txt[succ(b)]<>^M) then begin
    txt[b]:=' '; {change cr into sp, to append wrapped part to next line}
    checkWrap(b); {recursively check next line since it got stuff added}
    end;
   end;
  end;
 end;

procedure changeLines;begin
 trimLine; update:=true;  {signal to display to redraw}
 end;

procedure insChar(c:char);begin
 if endf=maxF then begin tooBigErr;exit;end;
 move(txt[crs],txt[succ(crs)],endf-crs);
 txt[crs]:=c;inc(crs);inc(endf);
 if c=^M then changeLines;
 checkWrap(crs);
 end;
procedure delChar;begin
 if crs=endf then exit;
 if txt[crs]=^M then changeLines;
 move(txt[succ(crs)],txt[crs],endf-crs);
 dec(endf);
 checkWrap(crs);
 end;

procedure addLF;var i:integer;begin
 for crs:=endF downto 1 do if txt[pred(crs)]=^M then begin
  insChar(^J); dec(crs);
  end;
 end;

procedure stripLF;var i:integer;begin
 for crs:=endF downto 0 do if txt[crs]=^J then delChar;
 end;

procedure writeErr;begin error('Write Error');end;

procedure saveFile;begin
 addLF;
 rewrite(theFile,1);
 if ioresult<>0 then writeErr
 else begin
  blockwrite(theFile,txt,endf);
  if ioresult<>0 then writeErr;
  close(theFile);
  end;
 end;

procedure newFile;begin crs:=0;endF:=0;update:=true;end;

procedure readErr;begin error('Read Error');end;

procedure loadFile;var i,n:integer;begin
 reset(theFile,1);
 if ioresult<>0 then newFile
 else begin
  n:=filesize(theFile);if n>maxF then begin tooBigErr;n:=maxF;end;
  blockread(theFile,txt,n,i);if i<n then readErr;
  close(theFile);
  crs:=0;endf:=i;update:=true;
  stripLF;
  end;
 end;

procedure signOff;var f:file;i,n:integer;begin
 assign(f,'signoff.txt');
 reset(f,1);
 if ioresult<>0 then error('No SIGNOFF.TXT defined')  {no macro defined}
 else begin
  n:=filesize(f);
  blockread(f,txt[endF],n,i);if i<n then readErr;
  close(f);
  inc(endf,i);update:=true;
  i:=crs; stripLF; crs:=i; {stripLF messes with crs}
  end;
 end;

procedure goLf;begin
 if crs>0 then dec(crs);
 if txt[crs]=^M then changeLines;
 end;
procedure goRt;begin
 if txt[crs]=^M then changeLines;
 if crs<endf then inc(crs);
 end;
procedure goCtrlLf;var c:char;begin
 repeat goLf;c:=txt[crs];until (c<=' ')or(crs=0);
 end;
procedure goCtrlRt;var c:char;begin
 repeat goRt;c:=txt[crs];until (c<=' ')or(crs>=endF);
 end;
procedure goUp;var i:integer;begin
 if lnBase>0 then begin
  changeLines;
  lnBase:=scanCrUp(pred(lnBase));crs:=lnBase;
  i:=scanCrDn(crs)-crs;
>>> Continued to next message

 * OLX 2.2 * "Could you continue your petty bickering? I find it most

--- Maximus 2.01wb
 * Origin: >>> Sun Mountain BBS <<< (303)-665-6922 (1:104/123)


                           >>> Continued from previous message
  if i>=x then inc(crs,x) else inc(crs,i);
  end;
 end;
procedure goDn;var i:integer;begin
 changeLines;
 crs:=scanCrDn(crs);if crs>=endF then exit;
 inc(crs);lnBase:=crs;
 i:=scanCrDn(crs)-crs;
 if i>=x then inc(crs,x) else inc(crs,i);
 end;
procedure goPgUp;var i:byte;begin for i:=halfPage downto 0 do goUp; end;
procedure goPgDn;var i:byte;begin for i:=halfPage downto 0 do goDn; end;
procedure goHome;begin crs:=scanCrUp(crs); end;
procedure goEnd;begin crs:=scanCrDn(crs); end;

procedure backChar;begin
 if (crs>0) then begin goLf; delChar; end;
 end;

procedure deleteLine;var i:integer;begin
 i:=scanCrDn(crs);crs:=scanCrUp(crs);
 if i<endF then begin move(txt[succ(i)],txt[crs],endf-i); dec(endF);end;
 dec(endf,i-crs); changeLines;
 end;

procedure flipCursor;var j,k,l:word;begin
 j:=succ((y*80+x)shl 1);
 l:=mem[vSeg:j];   {save attr under cursor}
 mem[vSeg:j]:=$7B; if not keypressed then syncTick;
 mem[vSeg:j]:=l; if not keypressed then syncTick;
 end;

procedure edit;var c:char;begin
 repeat
  display;
  repeat flipcursor;until keypressed;
  c:=readkey;
  if c=#0 then case readkey of
   #59:signOff;
   #75:goLf;
   #77:goRt;
   #115:goCtrlLf;
   #116:goCtrlRt;
   #72:goUp;
   #80:goDn;
   #83:delChar;
   #73:goPgUp;
   #81:goPgDn;
   #71:goHome;
   #79:goEnd;
   end
  else case c of
   ^[:saveFile;
   ^H:backChar;
   ^C:{abortFile};
   ^Y:deleteLine;
   else insChar(c);
   end;
  until (c=^[)or(c=^C);
 end;

function getRows:byte;assembler;asm
 mov ax,$1130; xor dx,dx; int $10;
 or dx,dx; jnz @S; mov dx,24; @S: {cga/mda don't have this fn}
 inc dx; mov al,dl;
 end;

var oldMode:byte;
begin
 asm mov ah,$F; int $10; mov oldMode,al; end;  {save old Gr mode}
 if oldMode=7 then vSeg:=$B000;  {check for Mono}
 nLines:=getRows;
 halfPage:=pred(nLines shr 1);
 cls; title;
 if paramCount=0 then error('Need filename as parameter')
 else begin
  asm mov bh,0; mov dl,0; mov dh,nLines; mov ah,2; int $10; end; {put cursor
of   assign(theFile,paramStr(1));
  loadFile;
  edit;
  end;
 end.

 * OLX 2.2 * "Could you continue your petty bickering? I find it most

--- Maximus 2.01wb
 * Origin: >>> Sun Mountain BBS <<< (303)-665-6922 (1:104/123)