gtext.inc 29 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1999-2000 by the Free Pascal development team
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************}
  11. {***************************************************************************}
  12. { Text output routines }
  13. {***************************************************************************}
  14. const
  15. maxfonts = 16; { maximum possible fonts }
  16. MaxChars = 255; { Maximum nr. of characters in a file }
  17. Prefix_Size = $80; { prefix size to skip }
  18. SIGNATURE = '+'; { Signature of CHR file }
  19. type
  20. (* pbyte = ^byte;
  21. pword = ^word;
  22. *)
  23. { Prefix header of Font file }
  24. { PFHeader = ^TFHeader;}
  25. TFHeader = packed record
  26. header_size: word; {* Version 2.0 Header Format *}
  27. font_name: array[1..4] of char;
  28. font_size: word; {* Size in byte of file *}
  29. font_major: byte; {* Driver Version Information *}
  30. font_minor: byte;
  31. min_major: byte; {* BGI Revision Information *}
  32. min_minor: byte;
  33. end;
  34. { Font record information }
  35. { PHeader = ^THeader;}
  36. THeader = packed record
  37. Signature: char; { signature byte }
  38. Nr_chars: smallint; { number of characters in file }
  39. Reserved: byte;
  40. First_char: byte; { first character in file }
  41. cdefs : smallint; { offset to character definitions }
  42. scan_flag: byte; { TRUE if char is scanable }
  43. org_to_cap: shortint; { Height from origin to top of capitol }
  44. org_to_base:shortint; { Height from origin to baseline }
  45. org_to_dec: shortint; { Height from origin to bot of decender }
  46. _reserved: array[1..4] of char;
  47. Unused: byte;
  48. end;
  49. TOffsetTable =array[0..MaxChars] of smallint;
  50. TWidthTable =array[0..MaxChars] of byte;
  51. tfontrec = packed record
  52. name : string[8];
  53. header : THeader; { font header }
  54. pheader : TFHeader; { prefix header }
  55. offsets : TOffsetTable;
  56. widths : TWidthTable;
  57. instrlength: longint; { length of instr, because instr can }
  58. instr : pchar; { contain null characters }
  59. end;
  60. { pStroke = ^TStroke;}
  61. TStroke = packed record
  62. opcode: byte;
  63. x: smallint; { relative x offset character }
  64. y: smallint; { relative y offset character }
  65. end;
  66. TStrokes = Array[0..1000] of TStroke;
  67. opcodes = (_END_OF_CHAR, _DO_SCAN, _MOVE, _DRAW);
  68. var
  69. fonts : array[1..maxfonts] of tfontrec;
  70. Strokes: TStrokes; {* Stroke Data Base *}
  71. { Stroke_count: Array[0..MaxChars] of smallint;} {* Stroke Count Table *}
  72. {***************************************************************************}
  73. { Internal support routines }
  74. {***************************************************************************}
  75. function testfont(p : pchar) : boolean;
  76. begin
  77. testfont:=(p[0]='P') and
  78. (p[1]='K') and
  79. (p[2]=#8) and
  80. (p[3]=#8);
  81. end;
  82. function InstallUserFont(const FontFileName : string) : smallint;
  83. begin
  84. _graphresult:=grOk;
  85. { first check if we do not allocate too many fonts! }
  86. if installedfonts=maxfonts then
  87. begin
  88. _graphresult:=grError;
  89. InstallUserFont := DefaultFont;
  90. exit;
  91. end;
  92. inc(installedfonts);
  93. fonts[installedfonts].name:=FontFileName;
  94. fonts[installedfonts].instr := nil;
  95. fonts[installedfonts].instrlength := 0;
  96. InstallUserFont:=installedfonts;
  97. end;
  98. function Decode(byte1,byte2: char; var x,y: smallint): smallint;
  99. { This routines decoes a signle word in a font opcode section }
  100. { to a stroke record. }
  101. var
  102. b1,b2: shortint;
  103. Begin
  104. b1:=shortint(byte1);
  105. b2:=shortint(byte2);
  106. { Decode the CHR OPCODE }
  107. Decode:=smallint(((b1 and $80) shr 6)+((b2 and $80) shr 7));
  108. { Now get the X,Y coordinates }
  109. { bit 0..7 only which are considered }
  110. { signed values. }
  111. {$R-}
  112. b1:=b1 and $7f;
  113. b2:=b2 and $7f;
  114. { Now if the MSB of these values are set }
  115. { then the value is signed, therefore we }
  116. { sign extend it... }
  117. if (b1 and $40)<>0 then b1:=b1 or $80;
  118. if (b2 and $40)<>0 then b2:=b2 or $80;
  119. x:=smallint(b1);
  120. y:=smallint(b2);
  121. {$ifdef debug}
  122. {$R+}
  123. {$endif debug}
  124. end;
  125. function unpack(buf: pchar; index: smallint; var Stroke: TStrokes): smallint;
  126. var
  127. po: TStrokes;
  128. num_ops: smallint;
  129. opcode, i, opc: word;
  130. counter: smallint;
  131. lindex: smallint;
  132. jx, jy: smallint;
  133. begin
  134. num_ops := 0;
  135. counter := index;
  136. lindex :=0;
  137. while TRUE do {* For each byte in buffer *}
  138. Begin
  139. Inc(num_ops); {* Count the operation *}
  140. opcode := decode( buf[counter], buf[counter+1] ,jx, jy );
  141. Inc(counter,2);
  142. if( opcode = ord(_END_OF_CHAR) ) then break; {* Exit loop at end of char *}
  143. end;
  144. counter:=index;
  145. for i:=0 to num_ops-1 do { /* For each opcode in buffer */ }
  146. Begin
  147. opc := decode(buf[counter], buf[counter+1], po[lindex].x, po[lindex].y); {* Decode the data field *}
  148. inc(counter,2);
  149. po[lindex].opcode := opc; {* Save the opcode *}
  150. Inc(lindex);
  151. end;
  152. Stroke:=po;
  153. unpack := num_ops; {* return OPS count *}
  154. end;
  155. procedure GetTextPosition(var xpos,ypos: longint; const TextString: string);
  156. begin
  157. if CurrentTextInfo.Font = DefaultFont then
  158. begin
  159. if Currenttextinfo.direction=horizdir then
  160. begin
  161. case Currenttextinfo.horiz of
  162. centertext : XPos:=(textwidth(textstring) shr 1);
  163. lefttext : XPos:=0;
  164. righttext : XPos:=textwidth(textstring);
  165. end;
  166. case Currenttextinfo.vert of
  167. centertext : YPos:=-(textheight(textstring) shr 1);
  168. bottomtext : YPos:=-textheight(textstring);
  169. toptext : YPos:=0;
  170. end;
  171. end else
  172. begin
  173. case Currenttextinfo.horiz of
  174. centertext : XPos:=(textheight(textstring) shr 1);
  175. lefttext : XPos:=textheight(textstring);
  176. righttext : XPos:=textheight(textstring);
  177. end;
  178. case Currenttextinfo.vert of
  179. centertext : YPos:=(textwidth(textstring) shr 1);
  180. bottomtext : YPos:=0;
  181. toptext : YPos:=textwidth(textstring);
  182. end;
  183. end;
  184. end
  185. else
  186. begin
  187. if Currenttextinfo.direction=horizdir then
  188. begin
  189. case CurrentTextInfo.horiz of
  190. centertext : XPos:=(textwidth(textstring) shr 1);
  191. lefttext : XPos:=0;
  192. righttext : XPos:=textwidth(textstring);
  193. end;
  194. case CurrentTextInfo.vert of
  195. centertext : YPos:=(textheight(textstring) shr 1);
  196. bottomtext : YPos:=0;
  197. toptext : YPos:=textheight(textstring);
  198. end;
  199. end else
  200. begin
  201. case CurrentTextInfo.horiz of
  202. centertext : XPos:=(textheight(textstring) shr 1);
  203. lefttext : XPos:=0;
  204. righttext : XPos:=textheight(textstring);
  205. end;
  206. case CurrentTextInfo.vert of
  207. centertext : YPos:=(textwidth(textstring) shr 1);
  208. bottomtext : YPos:=0;
  209. toptext : YPos:=textwidth(textstring);
  210. end;
  211. end;
  212. end;
  213. end;
  214. {***************************************************************************}
  215. { Exported routines }
  216. {***************************************************************************}
  217. function RegisterBGIfont(font : pointer) : smallint;
  218. var
  219. hp : pchar;
  220. b : word;
  221. i: longint;
  222. Header: THeader;
  223. counter: longint;
  224. FontData: pchar;
  225. FHeader: TFHeader;
  226. begin
  227. RegisterBGIfont:=grInvalidFontNum;
  228. i:=0;
  229. { Check if the font header is valid first of all }
  230. if testfont(font) then
  231. begin
  232. hp:=pchar(font);
  233. { Move to EOF in prefix header }
  234. while (hp[i] <> chr($1a)) do Inc(i);
  235. move(hp[i+1],FHeader,sizeof(FHeader));
  236. move(hp[Prefix_Size],header,sizeof(Header));
  237. { check if the font name is already allocated? }
  238. i:=Prefix_Size+sizeof(Header)+1;
  239. for b:=1 to installedfonts do
  240. begin
  241. if fonts[b].name=FHeader.Font_name then
  242. begin
  243. move(FHeader,fonts[b].PHeader,sizeof(FHeader));
  244. move(Header,fonts[b].Header,sizeof(Header));
  245. move(hp[i],Fonts[b].Offsets[Fonts[b].Header.First_Char],Fonts[b].Header.Nr_chars*sizeof(smallint));
  246. Inc(i,Fonts[b].Header.Nr_chars*sizeof(smallint));
  247. move(hp[i],Fonts[b].Widths[Fonts[b].Header.First_Char],Fonts[b].Header.Nr_chars*sizeof(byte));
  248. Inc(i,Fonts[b].Header.Nr_chars*sizeof(byte));
  249. counter:=Fonts[b].PHeader.font_size+PREFIX_SIZE-i;
  250. { allocate also space for null }
  251. GetMem(FontData,Counter+1);
  252. move(hp[i],FontData^,Counter);
  253. { Null terminate the string }
  254. FontData[counter+1] := #0;
  255. if fonts[b].header.Signature<> SIGNATURE then
  256. begin
  257. _graphResult:=grInvalidFont;
  258. Freemem(FontData, Counter+1);
  259. exit;
  260. end;
  261. fonts[b].instr:=FontData;
  262. fonts[b].instrlength:=Counter+1;
  263. RegisterBGIfont:=b;
  264. end;
  265. end;
  266. end
  267. else
  268. RegisterBGIFont:=grInvalidFont;
  269. end;
  270. procedure GetTextSettings(var TextInfo : TextSettingsType);
  271. begin
  272. textinfo:=currenttextinfo;
  273. end;
  274. function TextHeight(const TextString : string) : word;
  275. begin
  276. if Currenttextinfo.font=DefaultFont
  277. then TextHeight:=8*CurrentTextInfo.CharSize
  278. else
  279. TextHeight:=Trunc((fonts[Currenttextinfo.font].header.org_to_cap-
  280. fonts[Currenttextinfo.font].header.org_to_dec) * CurrentYRatio);
  281. end;
  282. function TextWidth(const TextString : string) : word;
  283. var i,x : smallint;
  284. c : byte;
  285. begin
  286. x := 0;
  287. { if this is the default font ... }
  288. if Currenttextinfo.font = Defaultfont then
  289. TextWidth:=length(TextString)*8*CurrentTextInfo.CharSize
  290. { This is a stroked font ... }
  291. else begin
  292. for i:=1 to length(TextString) do
  293. begin
  294. c:=byte(textstring[i]);
  295. { dec(c,fonts[Currenttextinfo.font].header.first_char);}
  296. if (c-fonts[Currenttextinfo.font].header.first_char>=
  297. fonts[Currenttextinfo.font].header.nr_chars) then
  298. continue;
  299. x:=x+byte(fonts[Currenttextinfo.font].widths[c]);
  300. end;
  301. TextWidth:=round(x * CurrentXRatio) ;
  302. end;
  303. end;
  304. procedure OutTextXY(x,y : smallint;const TextString : string);
  305. type
  306. Tpoint = record
  307. X,Y: smallint;
  308. end;
  309. var
  310. i,j,k,c : longint;
  311. xpos,ypos : longint;
  312. counter : longint;
  313. FontBitmap : TBitmapChar;
  314. cnt1,cnt2 : smallint;
  315. cnt3,cnt4 : smallint;
  316. charsize : word;
  317. WriteMode : word;
  318. CurX, CurY : smallint;
  319. curX2, curY2, xpos2, ypos2, x2, y2: graph_float;
  320. oldvalues : linesettingstype;
  321. chr : char;
  322. begin
  323. { save current write mode }
  324. WriteMode := CurrentWriteMode;
  325. CurrentWriteMode := NormalPut;
  326. GetTextPosition(xpos,ypos,textstring);
  327. X:=X-XPos; Y:=Y+YPos;
  328. XPos:=X; YPos:=Y;
  329. CharSize := CurrentTextInfo.Charsize;
  330. if Currenttextinfo.font=DefaultFont then
  331. begin
  332. c:=length(textstring);
  333. { We must a length strength which is ZERO based }
  334. { if c is a byte and length is zero, this is }
  335. { dangerous, fixed }
  336. Dec(c);
  337. if CurrentTextInfo.direction=HorizDir then
  338. { Horizontal direction }
  339. begin
  340. for i:=0 to c do
  341. begin
  342. chr := TextString[i+1];
  343. xpos:=x+(i shl 3)*Charsize;
  344. { we copy the character bitmap before accessing it }
  345. { this improves speed on non optimizing compilers }
  346. { since it is one less address calculation. }
  347. Fontbitmap:=TBitmapChar(DefaultFontData[chr]);
  348. { no scaling }
  349. if CharSize = 1 then
  350. Begin
  351. for j:=0 to 7 do
  352. for k:=0 to 7 do
  353. if Fontbitmap[j,k] <> 0 then PutPixel(xpos+k,j+y,CurrentColor);
  354. end
  355. else
  356. { perform scaling of bitmap font }
  357. Begin
  358. j:=0;
  359. cnt3:=0;
  360. while j <= 7 do
  361. begin
  362. { X-axis scaling }
  363. for cnt4 := 0 to charsize-1 do
  364. begin
  365. k:=0;
  366. cnt2 := 0;
  367. while k <= 7 do
  368. begin
  369. for cnt1 := 0 to charsize-1 do
  370. begin
  371. If FontBitmap[j,k] <> 0 then
  372. PutPixel(xpos+cnt1+cnt2,y+cnt3+cnt4,CurrentColor);
  373. end;
  374. Inc(k);
  375. Inc(cnt2,charsize);
  376. end;
  377. end;
  378. Inc(j);
  379. Inc(cnt3,charsize);
  380. end;
  381. end;
  382. end;
  383. end
  384. else
  385. { Vertical direction }
  386. begin
  387. for i:=0 to c do
  388. begin
  389. chr := TextString[i+1];
  390. Fontbitmap:=TBitmapChar(DefaultFontData[chr]);
  391. ypos := y-(i shl 3)*CharSize;
  392. { no scaling }
  393. if CharSize = 1 then
  394. Begin
  395. for j:=0 to 7 do
  396. for k:=0 to 7 do
  397. if Fontbitmap[j,k] <> 0 then PutPixel(xpos+j,ypos-k,
  398. CurrentColor);
  399. end
  400. else
  401. { perform scaling of bitmap font }
  402. Begin
  403. j:=0;
  404. cnt3:=0;
  405. while j<=7 do
  406. begin
  407. { X-axis scaling }
  408. for cnt4 := 0 to charsize-1 do
  409. begin
  410. k:=0;
  411. cnt2 := 0;
  412. while k<=7 do
  413. begin
  414. for cnt1 := 0 to charsize-1 do
  415. begin
  416. If FontBitmap[j,k] <> 0 then
  417. PutPixel(xpos+cnt3-cnt4,ypos+cnt1-cnt2,
  418. CurrentColor);
  419. end;
  420. Inc(k);
  421. Inc(cnt2,charsize);
  422. end;
  423. end;
  424. Inc(j);
  425. Inc(cnt3,charsize);
  426. end;
  427. end;
  428. end;
  429. end;
  430. end else
  431. { This is a stroked font which is already loaded into memory }
  432. begin
  433. getlinesettings(oldvalues);
  434. { reset line style to defaults }
  435. setlinestyle(solidln,oldvalues.pattern,normwidth);
  436. if Currenttextinfo.direction=vertdir then
  437. xpos:=xpos + Textheight(textstring);
  438. CurX2:=xpos; xpos2 := curX2; x2 := xpos2;
  439. CurY2:=ypos; ypos2 := curY2; y2 := ypos2;
  440. { x:=xpos; y:=ypos;}
  441. for i:=1 to length(textstring) do
  442. begin
  443. c:=byte(textstring[i]);
  444. { Stroke_Count[c] := }
  445. unpack( fonts[CurrentTextInfo.font].instr,
  446. fonts[CurrentTextInfo.font].Offsets[c], Strokes );
  447. counter:=0;
  448. while true do
  449. begin
  450. if CurrentTextInfo.direction=VertDir then
  451. begin
  452. xpos2:=x2-(Strokes[counter].Y*CurrentYRatio);
  453. ypos2:=y2-(Strokes[counter].X*CurrentXRatio);
  454. end
  455. else
  456. begin
  457. xpos2:=x2+(Strokes[counter].X*CurrentXRatio) ;
  458. ypos2:=y2-(Strokes[counter].Y*CurrentYRatio) ;
  459. end;
  460. case opcodes(Strokes[counter].opcode) of
  461. _END_OF_CHAR: break;
  462. _DO_SCAN: begin
  463. { Currently unsupported };
  464. end;
  465. _MOVE : Begin
  466. CurX2 := XPos2;
  467. CurY2 := YPos2;
  468. end;
  469. _DRAW: Begin
  470. Line(trunc(CurX2),trunc(CurY2),trunc(xpos2),trunc(ypos2));
  471. CurX2:=xpos2;
  472. CurY2:=ypos2;
  473. end;
  474. else
  475. Begin
  476. end;
  477. end;
  478. Inc(counter);
  479. end; { end while }
  480. if Currenttextinfo.direction=VertDir then
  481. y2:=y2-(byte(fonts[CurrenttextInfo.font].widths[c])*CurrentXRatio)
  482. else
  483. x2:=x2+(byte(fonts[Currenttextinfo.font].widths[c])*CurrentXRatio);
  484. end;
  485. setlinestyle( oldvalues.linestyle, oldvalues.pattern, oldvalues.thickness);
  486. end;
  487. { restore write mode }
  488. CurrentWriteMode := WriteMode;
  489. end;
  490. procedure OutText(const TextString : string);
  491. var x,y:smallint;
  492. begin
  493. { Save CP }
  494. x:=CurrentX;
  495. y:=CurrentY;
  496. OutTextXY(CurrentX,CurrentY,TextString);
  497. { If the direction is Horizontal and the justification left }
  498. { then and only then do we update the CP }
  499. if (Currenttextinfo.direction=HorizDir) and
  500. (Currenttextinfo.horiz=LeftText) then
  501. inc(x,textwidth(TextString));
  502. { Update the CP }
  503. CurrentX := X;
  504. CurrentY := Y;
  505. end;
  506. procedure SetTextJustify(horiz,vert : word);
  507. begin
  508. if (horiz<0) or (horiz>2) or
  509. (vert<0) or (vert>2) then
  510. begin
  511. _graphresult:=grError;
  512. exit;
  513. end;
  514. Currenttextinfo.horiz:=horiz;
  515. Currenttextinfo.vert:=vert;
  516. end;
  517. procedure SetTextStyle(font,direction : word;charsize : word);
  518. var
  519. f : file;
  520. Prefix: array[0..Prefix_Size-1] of char; {* File Prefix Holder *}
  521. Length, Current: longint;
  522. FontData: Pchar;
  523. Base: longint;
  524. hp : pchar;
  525. i : longint;
  526. begin
  527. if font>installedfonts then
  528. begin
  529. _graphresult:=grInvalidFontNum;
  530. exit;
  531. end;
  532. Currenttextinfo.font:=font;
  533. if (direction<>HorizDir) and (direction<>VertDir) then
  534. direction:=HorizDir;
  535. Currenttextinfo.direction:=direction;
  536. { According to the Turbo Pascal programmer's reference }
  537. { maximum charsize for bitmapped font is 10 }
  538. if (CurrentTextInfo.Font = DefaultFont) and (Charsize > 10) then
  539. Currenttextinfo.charsize:=10
  540. else if charsize<1 then
  541. Currenttextinfo.charsize:=1
  542. else
  543. Currenttextinfo.charsize:=charsize;
  544. { This is only valid for stroked fonts }
  545. {$ifdef logging}
  546. LogLn('(org_to_cap - org_to_dec): ' + strf(
  547. fonts[Currenttextinfo.font].header.org_to_cap-
  548. fonts[Currenttextinfo.font].header.org_to_dec));
  549. {$endif logging}
  550. if (charsize <> usercharsize) then
  551. Case CharSize of
  552. 1: Begin
  553. CurrentXRatio := 0.55;
  554. CurrentYRatio := 0.55;
  555. End;
  556. 2: Begin
  557. CurrentXRatio := 0.65;
  558. CurrentYRatio := 0.65;
  559. End;
  560. 3: Begin
  561. CurrentXRatio := 0.75;
  562. CurrentYRatio := 0.75;
  563. End;
  564. 4: Begin
  565. CurrentXRatio := 1.0;
  566. CurrentYRatio := 1.0;
  567. End;
  568. 5: Begin
  569. CurrentXRatio := 1.3;
  570. CurrentYRatio := 1.3;
  571. End;
  572. 6: Begin
  573. CurrentXRatio := 1.65;
  574. CurrentYRatio := 1.65
  575. End;
  576. 7: Begin
  577. CurrentXRatio := 2.0;
  578. CurrentYRatio := 2.0;
  579. End;
  580. 8: Begin
  581. CurrentXRatio := 2.5;
  582. CurrentYRatio := 2.5;
  583. End;
  584. 9: Begin
  585. CurrentXRatio := 3.0;
  586. CurrentYRatio := 3.0;
  587. End;
  588. 10: Begin
  589. CurrentXRatio := 4.0;
  590. CurrentYRatio := 4.0;
  591. End
  592. End;
  593. { if this is a stroked font then load it if not already loaded }
  594. { into memory... }
  595. if (font>DefaultFont) and not assigned(fonts[font].instr) then
  596. begin
  597. assign(f,bgipath+fonts[font].name+'.CHR');
  598. {$i-}
  599. reset(f,1);
  600. {$i+}
  601. if ioresult<>0 then
  602. begin
  603. _graphresult:=grFontNotFound;
  604. Currenttextinfo.font:=DefaultFont;
  605. exit;
  606. end;
  607. {* Read in the file prefix *}
  608. BlockRead(F, Prefix, Prefix_Size);
  609. hp:=Prefix;
  610. i:=0;
  611. while (hp[i] <> chr($1a)) do Inc(i);
  612. move(hp[i+1],fonts[font].PHeader,sizeof(TFHeader));
  613. (* Read in the Header file *)
  614. BlockRead(F,fonts[font].Header,Sizeof(THeader));
  615. Base := FilePos(F); {* Remember the address of table*}
  616. BlockRead(F,Fonts[font].Offsets[Fonts[font].Header.First_Char],Fonts[font].Header.Nr_chars*sizeof(smallint));
  617. {* Load the character width table into memory. *}
  618. base := filePos( f );
  619. BlockRead(F,Fonts[font].Widths[Fonts[font].Header.First_Char],Fonts[font].Header.Nr_chars*sizeof(byte));
  620. {* Determine the length of the stroke database. *}
  621. current := FilePos( f ); {* Current file location *}
  622. Seek( f, FileSize(F)); {* Go to the end of the file *}
  623. length := FilePos( f ); {* Get the file length *}
  624. Seek( f, current); {* Restore old file location *}
  625. {* Load the stroke database. *}
  626. { also allocate space for Null character }
  627. Getmem(FontData, Length+1); {* Create space for font data *}
  628. BlockRead(F, FontData^, length-current); {* Load the stroke data *}
  629. FontData[length-current+1] := #0;
  630. if fonts[font].header.Signature<> SIGNATURE then
  631. begin
  632. _graphResult:=grInvalidFont;
  633. Currenttextinfo.font:=DefaultFont;
  634. Freemem(FontData, Length+1);
  635. exit;
  636. end;
  637. fonts[font].instr:=FontData;
  638. fonts[font].instrLength:=Length+1;
  639. if not testfont(Prefix) then
  640. begin
  641. _graphresult:=grInvalidFont;
  642. Currenttextinfo.font:=DefaultFont;
  643. Freemem(FontData, Length+1);
  644. end;
  645. close(f);
  646. end;
  647. end;
  648. procedure SetUserCharSize(Multx,Divx,Multy,Divy : word);
  649. begin
  650. CurrentXRatio := MultX / DivX;
  651. CurrentYRatio := MultY / DivY;
  652. end;
  653. {
  654. $Log$
  655. Revision 1.14 2000-01-07 16:41:38 daniel
  656. * copyright 2000
  657. Revision 1.13 2000/01/07 16:32:26 daniel
  658. * copyright 2000 added
  659. Revision 1.12 2000/01/06 16:17:56 jonas
  660. * fixed bug in outTextXY for vertical text
  661. Revision 1.11 2000/01/02 19:02:39 jonas
  662. * removed/commented out (inited but) unused vars and unused types
  663. Revision 1.10 1999/12/23 16:48:13 jonas
  664. * turn off IO checking when attempting to open a font file (to avoid RTE)
  665. Revision 1.9 1999/12/20 11:22:36 peter
  666. * integer -> smallint to overcome -S2 switch needed for ggi version
  667. Revision 1.8 1999/11/11 22:29:21 florian
  668. * the writing of the default font was wrong when doing scaling:
  669. the last colunm/row wasn't drawn
  670. Revision 1.7 1999/09/28 15:07:47 jonas
  671. * fix for disposing font data because it can contain #0 chars
  672. Revision 1.6 1999/09/28 13:56:29 jonas
  673. * reordered some local variables (first 4 byte vars, then 2 byte vars
  674. etc)
  675. * font data is now disposed in exitproc, exitproc is now called
  676. GraphExitProc (was CleanModes) and resides in graph.pp instead of in
  677. modes.inc
  678. Revision 1.5 1999/09/27 23:34:42 peter
  679. * new graph unit is default for go32v2
  680. * removed warnings/notes
  681. Revision 1.4 1999/09/26 13:31:07 jonas
  682. * changed name of modeinfo variable to vesamodeinfo and fixed
  683. associated errors (fillchar(modeinfo,sizeof(tmodeinfo),#0) instead
  684. of sizeof(TVesamodeinfo) etc)
  685. * changed several sizeof(type) to sizeof(varname) to avoid similar
  686. errors in the future
  687. Revision 1.3 1999/09/22 14:54:11 jonas
  688. * changed ratios so font sizes on screen are the same as with TP
  689. * SetUserCharSize must also use / instead of DIV
  690. Revision 1.2 1999/09/22 13:30:52 jonas
  691. * changed org_to_cap, org_to_dec and org_to_base to shortint (from
  692. Michael Knapp's gxtext unit, part of the GraphiX package)
  693. * in settextstyle, the calculation of the ratios must be done
  694. with /, not DIV!!
  695. Revision 1.1 1999/09/22 13:13:36 jonas
  696. * renamed text.inc -> gtext.inc to avoid conflict with system unit
  697. * fixed textwidth
  698. * isgraphmode now gets properly updated, so mode restoring works
  699. again
  700. Revision 1.7 1999/09/12 17:29:00 jonas
  701. * several changes to internalellipse to make it faster
  702. and to make sure it updates the ArcCall correctly
  703. (not yet done for width = 3)
  704. * Arc mostly works now, only sometimes an endless loop, don't know
  705. why
  706. Revision 1.6 1999/09/12 08:02:22 florian
  707. * fixed outtext(''), c was a byte, this leads to an underflow and
  708. garbage was written
  709. Revision 1.5 1999/07/26 09:38:43 florian
  710. * bar: y2 can be less y1, fixed
  711. * settextstyle: charsize can be 0, must be changed into 1
  712. Revision 1.4 1999/07/12 13:27:16 jonas
  713. + added Log and Id tags
  714. * added first FPC support, only VGA works to some extend for now
  715. * use -dasmgraph to use assembler routines, otherwise Pascal
  716. equivalents are used
  717. * use -dsupportVESA to support VESA (crashes under FPC for now)
  718. * only dispose vesainfo at closegrph if a vesa card was detected
  719. * changed int32 to longint (int32 is not declared under FPC)
  720. * changed the declaration of almost every procedure in graph.inc to
  721. "far;" becquse otherwise you can't assign them to procvars under TP
  722. real mode (but unexplainable "data segnment too large" errors prevent
  723. it from working under real mode anyway)
  724. }