|
DataMuseum.dkPresents historical artifacts from the history of: RegneCentralen RC759 "Piccoline" |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RegneCentralen RC759 "Piccoline" Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 11710 (0x2dbe)
Types: TextFile
Names: »CHAREDIT.PAS«
└─⟦d4ddf50a0⟧ Bits:30004478 CPI-graf 2.5 til Piccoline/Partner
└─⟦this⟧ »CHAREDIT.PAS«
uses cpigraf, cpifont, cpimenu;
const
xl= 8;
yl =4;
picmaxx=36;
picmaxy=36;
special: array(.0..15.) of byte =
($00,$00,$00,$00,$FF,$FF,$FF,$FF,$18,$ff,$ff,$18,$e7,$00,$00,$e7);
mainmenu: array(.1..6.) of menutype = (
(c:'P';s:'Pr▶9b◀ve '),
(c:'F';s:'Filer '),
(c:'R';s:'Rediger tegn '),
(c:'T';s:'nyt Tegn '),
(c:'+';s:'+1 tegn '),
(c:'-';s:'-1 tegn ')
);
submenu1: array(.1..6.) of menutype = (
(c:'F';s:'ny Font'),
(c:'N';s:'fontNavn'),
(c:'H';s:'Hent font'),
(c:'G';s:'Gem font'),
(c:'A';s:'Afslut'),
(c:'B';s:'hent Bin▶91◀r'));
submenu2: array(.1..3.) of menutype = (
(c:'T';s:'rediger Tegn'),
(c:'K';s:'tegn Kopi'),
(c:'P';s:'Paste tegn'));
submenu3: array(.1..2.) of menutype = (
(c:'U';s:'Udskriv pr▶9b◀ve'),
(c:'N';s:'Ny pr▶9b◀ve'));
submenu4: array(.1..2.) of menutype = (
(c:'T';s:'Tast et tegn'),
(c:'A';s:'tast ASCII v▶91◀rdi'));
dialog0: array(.1..9.) of string(.40.) = (
'Angiv parametre for en ny font: ',
'========================================',
'Fontnavn :',
'x-bits :',
'y-bits :',
'ASCII-fra :',
'ASCII-til :',
'<pilop> og <pilned> skifter',
'<ESC>fortryd, <RETUR> ret');
oktext: string(.2.) = 'OK';
var
savepic,pic: array(.1..picmaxx,1..picmaxy.) of boolean;
fname, fname2,pr: str80;
chno2, chno, i, j, k: integer;
tto,ffrom,xx,yy,xx1,yy1,fntno,lastx, lasty: integer;
lastbit: boolean;
st: str80;
err: boolean;
fnt_to2,fnt_from2: integer;
fnt_xlgt2, fnt_ylgt2: integer;
win1,win2,win3, win6,win5, win7: wnd_id;
res: resourcetype;
procedure initedit;
var err: boolean;
begin
initfont;
for i:=1 to picmaxx do
for j:=1 to picmaxy do
pic(.i,j.):=false;
with fnt_arr(.3.) do begin
cto:=4; cfrom:=0; xlgt:=8; ylgt:=4; tot:=4;
buf:=addr(special);
end;
end; (* procedure initedit *)
procedure writecurs(x,y: integer; bit: boolean;sw: boolean);
begin
if sw then scr_drawblock(lastx,lasty,fnt_ptr(.integer(lastbit).));
x:=x*(xl+1)+wnd_x1;
y:=y*(yl+1)+wnd_y1;
if sw then scr_drawblock(x,y,fnt_ptr(.2+byte(bit).));
lastx:=x; lasty:=y; lastbit:=bit;
end; (* procedure writebit(x,y: integer; bit: boolean) *)
procedure writebit(x,y: integer; bit: boolean);
begin
x:=x*(xl+1)+wnd_x1;
y:=y*(yl+1)+wnd_y1;
scr_drawblock(x,y,fnt_ptr(.integer(bit).));
end; (* procedure writebit(x,y: integer; bit: boolean) *)
procedure writepic;
var
i,j,xlg,ylg: integer;
p: boolean;
begin
xlg:=fnt_xlgt;
ylg:=fnt_ylgt;
selectfont(3);
for i:=1 to xlg do
for j:=1 to ylg do begin
p:=pic(.i,j.);
if p then writebit(i,j,p);
end;
end; (* procedure writepic; *)
procedure bittopic(no:byte);
var
i,x,y: byte;
segbit, ofsbit: integer;
b: byte;
begin
selectfont(1);
i:=0;
segbit:=fnt_segm;
ofsbit:=fnt_ptr(.no.);
for y:= fnt_ylgt downto 1 do begin
for x:=1 to fnt_xlgt do begin
if (x-1) mod 8=0 then
begin b:=mem(.segbit:ofsbit.);ofsbit:=ofsbit+1; end;
pic(.x,y.):=(b and $80=$80);
b:=lo(b shl 1);
end;
end;
end;
procedure pictobit(no: byte);
const maske: array(.0..7.) of byte =
($1,$2,$4,$8,$10,$20,$40,$80);
var
x,x1,y: byte;
segbit, ofsbit: integer;
b: byte;
begin
selectfont(1);
segbit:=fnt_segm;
ofsbit:=fnt_ptr(.no.);
for y:= fnt_ylgt downto 1 do begin
b:=0; x1:=0;
for x:= 1 to fnt_xlgt do begin
if pic(.x,y.) then b:=lo(b or maske(.7-x1.));
if (x1 = 7) then begin
mem(.segbit:ofsbit.):=b;
b:=0 ; ofsbit:=ofsbit+1; x1:=0;
end else begin
x1:=x1+1;
end;
if (x=fnt_xlgt) and (x1>0) then begin
mem(.segbit:ofsbit.):=b;
b:=0; ofsbit:=ofsbit+1; x1:=0;
end;
end;
end;
end; (* procedure pictobit(no: byte) *)
procedure showfont;
var
i,l,l1: integer;
begin
selectfont(1);
selectviewport(win6);
drawfont(8,8,pr);
repeat readchar until char2 in (.#13,#27.);
hideviewport(win6)
end; (* procedure font *)
procedure setupviewport;
begin
selectfont(1);
closeviewport(win2);
newviewport(win2,0,(xl+1)*fnt_xlgt+15,0,(yl+1)*fnt_ylgt+6);
setviewporttype(win2,(.Wnonhide.));
setviewportcolor(win2,white,black);
closeviewport(win3);
newviewport(win3,(xl+1)*fnt_xlgt+32,(xl+1)*fnt_xlgt+36+fnt_xlgt,0,fnt_ylgt+1);
setviewporttype(win3,(.Wnonhide,wdrawframe.));
setviewportcolor(win3,black,white);
closeviewport(win6);
newviewport(win6,0,scr_maxx,100,116+fnt_ylgt);
setviewporttype(win6,(.Wnonhide,wdrawframe.));
end;
procedure setupdraw1;
begin
selectfont(1);
selectviewport(win5);
writetext(0,3,'Ascii:');
writereal(7,3,chno,3,0);
selectviewport(win3);
selectfont(1);
drawfont(2,0,chr(chno));
selectviewport(win2);
selectfont(1);
clearviewport;
drawframe;
bittopic(chno);
writepic;
selectfont(3);
writecurs(xx,yy,pic(.xx,yy.),false);
selectfont(1);
end;
procedure setupdraw2;
begin
selectfont(1);
selectviewport(win5);
writetext(0,1,fname);
writetext(0,2,'Bits: x');
writereal(7,2,fnt_xlgt,3,0);
writereal(13,2,fnt_ylgt,3,0);
writetext(0,4,'<F1> g▶86◀ til tegn');
writetext(0,5,'<F2> slet r▶91◀kke');
writetext(0,6,'<F3> inds▶91◀t r▶91◀kke');
writetext(0,7,'<F4> slet kolonne');
writetext(0,8,'<F5> inds▶91◀t kol.');
writetext(0,9,'<ESC> for menu');
end;
procedure putfont(fntno: integer; name: str80; var err: boolean);
var
ii,i,j: integer;
begin
if pos('.',name)=0 then name:=name+'.set';
sys_openfile(name,fil_write,err);
if err then exit;
with fnt_arr(.fntno.) do begin
cto:=cto-cfrom;
sys_writefile(7,flgt);
sys_writefile(flgt-7,buf^);
cto:=cto+cfrom;
end;
sys_closefile(fil_write);
end;
procedure getfont(sw: boolean);
var
a,b,err : boolean;
name: str80;
begin
if sw then begin
err:=false;
name:=fname;
if pos('.',name)=0 then name:=name+'.set';
readfont(1,name,err);
end;
selectfont(1);
fnt_xlgt2:=fnt_xlgt;
fnt_ylgt2:=fnt_ylgt;
fnt_from2:=fnt_from;
fnt_to2:=fnt_to;
fname2:=fname;
chno:=fnt_from;
xx1:=fnt_xlgt;
yy1:=fnt_ylgt;
tto:=fnt_to;
ffrom:=fnt_from;
xx:=xx1 div 2; yy:=yy1 div 2;
setupviewport;
setupdraw2;
setupdraw1;
end;
procedure rediger;
var i: integer;
begin
setupdraw1;
selectfont(3);
repeat
writecurs(xx,yy,pic(.xx,yy.),true);
readchar;
case char2 of
fup :if yy+1<=yy1 then yy:=yy+1;
fpgup :if (yy+1<=yy1) and (xx+1<=xx1) then begin yy:=yy+1; xx:=xx+1 end;
fpgdn :if (yy-1>=1) and (xx+1<=xx1) then begin yy:=yy-1; xx:=xx+1 end;
fend :if (yy-1>=1) and (xx-1>=1) then begin yy:=yy-1; xx:=xx-1 end;
fhome :if (yy+1<=yy1) and (xx-1>=1) then begin yy:=yy+1; xx:=xx-1 end;
Fdown :if yy-1>=1 then yy:=yy-1;
fright :if xx+1<=xx1 then xx:=xx+1;
fleft :if xx-1>=1 then xx:=xx-1;
^M,' ' :
begin
pic(.xx,yy.):=not pic(.xx,yy.);
selectviewport(win3);
(* clearviewport;*)
selectfont(1);
pictobit(chno);
drawfont(2,0,chr(chno));
end;
f1: begin
selectviewport(win7);
writetext(0,0,'Tryk en taste');
selectfont(1);
repeat
readchar;
i:=ord(char2);
until (i>=fnt_from) and (i<=fnt_to);
hideviewport(win7);
chno:=i;
setupdraw1;
char2:='+';
end;
f2: begin
selectfont(1);
for i:=yy to fnt_ylgt-1 do
for j:=1 to fnt_xlgt do pic(.j,i.):=pic(.j,i+1.);
for j:=1 to fnt_xlgt do pic(.j,fnt_ylgt.):=false;
pictobit(chno);
setupdraw1;
char2:='+';
end;
f3: begin
selectfont(1);
for i:=fnt_ylgt downto yy+1 do
for j:=1 to fnt_xlgt do pic(.j,i.):=pic(.j,i-1.);
pictobit(chno);
setupdraw1;
char2:='+';
end;
f4: begin
selectfont(1);
for i:=xx to fnt_xlgt-1 do
for j:=1 to fnt_ylgt do pic(.i,j.):=pic(.i+1,j.);
for j:=1 to fnt_ylgt do pic(.fnt_xlgt,j.):=false;
pictobit(chno);
setupdraw1;
char2:='+';
end;
f5: begin
selectfont(1);
for i:=fnt_xlgt downto xx+1 do
for j:=1 to fnt_ylgt do pic(.i,j.):=pic(.i-1,j.);
pictobit(chno);
setupdraw1;
char2:='+';
end;
'+':
if (chno+1)<=tto then begin chno:=chno+1;
setupdraw1 end;
'-':
if (chno-1)>=ffrom then begin chno:=chno-1;
setupdraw1 end;
else
end;
if char2 in (.'+','-',^M,' '.) then begin
selectviewport(win2);
selectfont(3);
end;
until char2=esc;
selectfont(1);
end; (* procedure rediger *)
Var char3: string(.1.);
ii: integer;
æ$F+å
procedure hertil;
begin
selectfonT(1);
ii:=ord(char3(.1.));
if (char2<>esc) and (ii>=fnt_from) and (ii<=fnt_to) then begin
chno:=ii;
setupdraw1;
men_end:=true;
end;
end;
procedure hertil2;
begin
selectfonT(1);
ii:=chno2;
if (char2<>esc) and (ii>=fnt_from) and (ii<=fnt_to) then begin
chno:=ii;
setupdraw1;
men_end:=true;
end;
end;
æ$F-å
begin
char3:='A';
pr:='!"# 124 ABC abc ▶92◀▶91◀';
fname:='normal';
graphicscreen(ibm_high);
newResource(res,0,0,'');
addmenu(6,mainmenu,'',horizontal);
addmenu(5,submenu1,'F',vertical);
addmenu(3,submenu2,'R',vertical);
addmenu(2,submenu3,'P',vertical);
addmenu(2,submenu4,'T',vertical);
addialog(15,8,7,'FF');
dlg_addtext(0,0,40,9,dialog0,'FF0');
dlg_addstr(15,2,25,fname2,'FF1');
dlg_addinteger(15,3,3,fnt_xlgt2,'FF2');
dlg_addinteger(15,4,3,fnt_ylgt2,'FF3');
dlg_addinteger(15,5,3,fnt_from2,'FF4');
dlg_addinteger(15,6,3,fnt_to2,'FF5');
dlg_addtext(35,0,2,1,oktext,'FF6');
addstr(sizeof(pr),pr,'PN');
addstr(60,fname,'FN');
addstr(1,char3,'TT');
addinteger(3,chno2,'TA');
addproc(@hertil,'TT');
addproc(@hertil2,'TA');
graphmode;
newtextviewport(win5,txt_maxx-20,txt_maxx,txt_maxy-12,txt_maxy);
setviewporttype(win5,(.wwriteframe,wnonhide.));
setviewportcolor(win5,black,white);
newtextviewport(win7,35,50,10,12);
setviewporttype(win7,(.wwriteframe.));
initedit;
getfont(true);
repeat
resourcedisplay;
if men_selec='FH' then
getfont(true) else
if men_selec='FG' then
putfont(1,fname,err) else
if men_selec='FA' then
begin textmode; halt end else
if Men_selec='RT' then
rediger else
if men_selec='RK' then
savepic:=pic else
if men_selec='RP' then
begin pic:=savepic; pictobit(chno); setupdraw1; end else
if men_selec='+' then
begin if (chno+1)<=fnt_to then begin chno:=chno+1; setupdraw1 end end else
if men_selec='-' then
begin if (chno-1)>=fnt_from then begin chno:=chno-1; setupdraw1 end end else
if men_selec='PU' then
showfont else
if (Men_selec='FF6') and (char2=#13) then begin
selectfont(1);
fname:=fname2;
with fnt_arr(.fnt_actual.) do begin
freemem(buf,flgt);
xlgt:=fnt_xlgt2; ylgt:=fnt_ylgt2; cfrom:=fnt_from2; cto:=fnt_to2;
tot:=(xlgt+7) div 8 * ylgt;
flgt:=tot*(cto-cfrom+1)+7;
getmem(buf,flgt);
fillchar(buf^,flgt-7,0);
end;
getfont(false);
end;
until false;
textmode;
end.
«eof»