gameunit.pp 20 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890
  1. {
  2. $Id$
  3. A simple unit with some common used routines for FPCGames (FpcTris and
  4. SameGame)
  5. Contains
  6. - Highscore routines "developped" for FPCTris, but now also used by SameGame
  7. - "Dummy" mouse routines which either shell to API units or to MSMouse.
  8. See the file COPYING.FPC, included in this distribution,
  9. for details about the copyright.
  10. This program is distributed in the hope that it will be useful,
  11. but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  13. **********************************************************************}
  14. UNIT GameUnit;
  15. INTERFACE
  16. {MouseAPI defined : unit unes API mouse units, which requires that package,
  17. but also works under Linux
  18. MouseAPI undef : RTL unit MsMouse. API not required, but doesn't work under
  19. Linux }
  20. {$ifdef linux}
  21. {$define MouseAPI}
  22. {$endif}
  23. {$ifdef win32}
  24. {$define MouseAPI}
  25. {$endif}
  26. {$IFDEF Ver70}
  27. {$define MouseAPI}
  28. {$G+}
  29. {$endif}
  30. {$IFDEF Ver60}
  31. {$define MouseAPI}
  32. {$G+}
  33. {$endif}
  34. {$IFDEF Ver55}
  35. {$define MouseAPI}
  36. {$G+}
  37. {$endif}
  38. CONST LineDistY=13;
  39. TYPE CHARSET=SET OF CHAR;
  40. {---- Unified Mouse procedures. ---- }
  41. FUNCTION MousePresent : BOOLEAN;
  42. PROCEDURE HideMouse;
  43. PROCEDURE ShowMouse;
  44. PROCEDURE GetMouseState(VAR MX,MY,MState : LONGINT);
  45. PROCEDURE DoneMouse;
  46. PROCEDURE InitMouse;
  47. PROCEDURE SetMousePosition(X,Y:LONGINT);
  48. Const LButton = 1; {left button}
  49. RButton = 2; {right button}
  50. MButton = 4; {middle button}
  51. {---- Standard Highscore procedures ----}
  52. TYPE HighScoreType = Packed RECORD
  53. Name : String[15];
  54. Score: LONGINT;
  55. END;
  56. HighScoreArr = ARRAY[0..9] OF HighScoreType;
  57. VAR HighScore : HighScoreArr;
  58. ScorePath : String;
  59. HighX,HighY : LONGINT;
  60. Negative : BOOLEAN; { Negative=true-> better scores are lower}
  61. PROCEDURE LoadHighScore(FileName:STRING);
  62. PROCEDURE SaveHighScore;
  63. PROCEDURE ShowHighScore;
  64. FUNCTION SlipInScore(Score:LONGINT):LONGINT;
  65. {---- Keyboard routines ----}
  66. CONST {Constants for GetKey}
  67. ArrU = $04800; ArrL = $04B00; ArrR = $04D00; BS = $08; (* Backspace *)
  68. ArrD = $05000; CR = $0D; ESC = $1B; KDelete= $05300;
  69. KInsert= $05200; Home = $04700; KEnd = $04F00; CtrlY = $19;
  70. CtrlT = $14;
  71. CONST FieldSpace : CHAR = #177;
  72. AlfaBeta : CHARSET= [' '..'z'];
  73. FUNCTION GetKey:LONGINT;
  74. {Generic string input routine}
  75. {$IFDEF UseGraphics}
  76. FUNCTION GrInputStr(VAR S:String;X,Y,Len,dX,dY:LONGINT;TextIn:BOOLEAN;CharAllow:CHARSET):BOOLEAN;
  77. {$ELSE}
  78. FUNCTION InputStr(VAR S:String;X,Y,Len:LONGINT;TextIn:BOOLEAN;CharAllow:CHARSET):BOOLEAN;
  79. {$ENDIF}
  80. {---- Misc ----}
  81. PROCEDURE SetDefaultColor; {Restore the attribs saved on startup}
  82. {BP compability}
  83. {$IFNDEF FPC}
  84. PROCEDURE SetCursorSize(CurDat:WORD);
  85. FUNCTION GetCursorSize:WORD;
  86. PROCEDURE CursorOn;
  87. PROCEDURE CursorOff;
  88. {Non Go32 but not existant in BP}
  89. PROCEDURE FillWord(VAR Data;Count,Value:WORD);
  90. PROCEDURE dosmemfillword(Segx,xofs,Count,Value:WORD);
  91. PROCEDURE dosmemput(Segx,xofs:WORD;VAR Data;Count:WORD);
  92. PROCEDURE dosmemget(Segx,xofs:WORD;VAR Data;Count:WORD);
  93. FUNCTION inportb(portx : word) : byte;
  94. PROCEDURE outportb(portx : word;data : byte);
  95. FUNCTION inportw(portx : word) : word;
  96. PROCEDURE outportw(portx : word;data : word);
  97. FUNCTION inportl(portx : word) : longint;
  98. PROCEDURE outportl(portx : word;data : longint);
  99. {$ENDIF}
  100. IMPLEMENTATION
  101. {$IFDEF MouseAPI}
  102. {$IFDEF UseGraphics}
  103. Uses Mouse,Dos,Crt,Graph;
  104. {$ELSE}
  105. Uses Mouse,Dos,Crt;
  106. {$ENDIF}
  107. {$ELSE}
  108. {$IFDEF UseGraphics}
  109. Uses MsMouse,Dos,Crt,Graph;
  110. {$ELSE}
  111. Uses MsMouse,Dos,Crt;
  112. {$ENDIF}
  113. {$ENDIF}
  114. VAR DefColor : BYTE; {Backup of startup colors}
  115. CONST
  116. {The initial names. If people feel they are missing, I first checked the Alias,
  117. and then filled with names of the FPC-Devel list, and arranged them alfabetically}
  118. InitNames : ARRAY[0..9] OF String[12] = ('Carl','Daniel','Florian','Jonas','John','Marco','Michael (3x)',
  119. 'Peter','Pierre','Thomas' );
  120. FUNCTION MousePresent : BOOLEAN;
  121. BEGIN
  122. {$IFDEF MouseAPI}
  123. MousePresent:=DetectMouse<>0;
  124. {$ELSE}
  125. MousePresent:=MouseFound;
  126. {$ENDIF}
  127. END;
  128. PROCEDURE ShowMouse;
  129. BEGIN
  130. {$IFDEF MouseAPI}
  131. Mouse.ShowMouse;
  132. {$ELSE}
  133. MsMouse.ShowMouse;
  134. {$ENDIF}
  135. END;
  136. PROCEDURE HideMouse;
  137. BEGIN
  138. {$IFDEF MouseAPI}
  139. Mouse.HideMouse;
  140. {$ELSE}
  141. MsMouse.HideMouse;
  142. {$ENDIF}
  143. END;
  144. PROCEDURE InitMouse;
  145. BEGIN
  146. {$IFDEF MouseAPI}
  147. Mouse.InitMouse;
  148. {$ELSE}
  149. MsMouse.InitMouse;
  150. {$ENDIF}
  151. END;
  152. PROCEDURE DoneMouse;
  153. BEGIN
  154. {$IFDEF MouseAPI}
  155. Mouse.DoneMouse;
  156. {$ENDIF}
  157. END;
  158. PROCEDURE GetMouseState(VAR MX,MY,MState : LONGINT);
  159. {$IFDEF MouseAPI}
  160. VAR MouseEvent : TMouseEvent;
  161. {$ENDIF}
  162. BEGIN
  163. {$IFDEF MouseAPI}
  164. GetMouseEvent(MouseEvent);
  165. MX:=MouseEvent.X SHL 3;
  166. MY:=MouseEvent.Y SHL 3;
  167. MState:=MouseEvent.Buttons;
  168. {$ELSE}
  169. MsMouse.GetMouseState(MX,MY,MState);
  170. {$ENDIF}
  171. END;
  172. PROCEDURE SetMousePosition(X,Y:LONGINT);
  173. BEGIN
  174. {$IFDEF MouseAPI}
  175. SetMouseXY(x,y);
  176. {$ELSE}
  177. SetMousePos(X,Y);
  178. {$ENDIF}
  179. END;
  180. Procedure LoadHighScore(FileName:STRING);
  181. var
  182. F: File;
  183. I : LONGINT;
  184. OFileMode : LONGINT;
  185. BEGIN
  186. {$I-}
  187. Assign(F, FileName);
  188. OFileMode:=FileMode;
  189. FileMode := 0; {Set file access to read only }
  190. Reset(F);
  191. Close(F);
  192. {$I+}
  193. IF IOResult=0 THEN
  194. ScorePath:=FileName
  195. ELSE
  196. ScorePath:=FSearch(FileName,GetEnv('PATH'));
  197. IF ScorePath='' THEN
  198. BEGIN
  199. FOR I:=0 TO 9 DO
  200. BEGIN
  201. HighScore[I].Name:=InitNames[I];
  202. HighScore[I].Score:=(I+1)*750;
  203. END;
  204. ScorePath:=FileName;
  205. END
  206. ELSE
  207. BEGIN
  208. Assign(F,ScorePath);
  209. Reset(F,1);
  210. BlockRead(F,HighScore,SIZEOF(HighScoreArr));
  211. Close(F);
  212. END;
  213. FileMode:=OFileMode;
  214. END;
  215. Procedure SaveHighScore;
  216. var
  217. F: File;
  218. BEGIN
  219. Assign(F,ScorePath);
  220. Rewrite(F,1);
  221. BlockWrite(F,HighScore,SIZEOF(HighScoreArr));
  222. Close(F);
  223. END;
  224. FUNCTION SlipInScore(Score:LONGINT):LONGINT;
  225. VAR I,J : LONGINT;
  226. BEGIN
  227. IF Negative THEN
  228. Score:=-Score;
  229. I:=0;
  230. WHILE (Score>HighScore[I].Score) AND (I<10) DO
  231. INC(I);
  232. IF I<>0 THEN
  233. BEGIN
  234. IF I>1 THEN
  235. FOR J:=0 TO I-2 DO
  236. HighScore[J]:=HighScore[J+1];
  237. HighScore[I-1].Score:=Score;
  238. HighScore[I-1].Name:='';
  239. END;
  240. SlipInScore:=I;
  241. END;
  242. {$IFDEF UseGraphics}
  243. PROCEDURE ShowHighScore;
  244. VAR I : LONGINT;
  245. S : String;
  246. BEGIN
  247. SetFillStyle(SolidFill,0); {Clear part of playfield}
  248. Bar(HighX,HighY, 638, HighY+20+18*LineDistY);
  249. FOR I:=0 TO 9 DO
  250. BEGIN
  251. OutTextXY(HighX,HighY+(9-I)*LineDistY,HighScore[I].Name);
  252. IF Negative THEN
  253. Str(-HighScore[I].Score:5,S)
  254. ELSE
  255. Str(HighScore[I].Score:5,S);
  256. OutTextXY(HighX+150,HighY+(9-I)*LineDistY,S);
  257. END;
  258. END;
  259. {$ELSE}
  260. PROCEDURE ShowHighScore;
  261. VAR I : LONGINT;
  262. {HighX=40 HighY=9}
  263. BEGIN
  264. GotoXY(HighX+5,9); Write('The Highscores');
  265. FOR I:=0 TO 9 DO
  266. BEGIN
  267. GotoXY(HighX,HighY+11-I);
  268. Write(HighScore[I].Name,' ':(13-Length(HighScore[I].Name)),' ');
  269. IF NOT Negative THEN { Negative=true-> better scores are lower}
  270. Write(HighScore[I].Score:5)
  271. ELSE
  272. Write(-HighScore[I].Score:5)
  273. END;
  274. END;
  275. {$ENDIF}
  276. FUNCTION GetKey:LONGINT;
  277. VAR InKey: LONGINT;
  278. BEGIN
  279. InKey:=ORD(ReadKey);
  280. IF InKey=0 THEN InKey:=ORD(ReadKey) SHL 8;
  281. GetKey:=InKey;
  282. END;
  283. {$IFNDEF UseGraphics}
  284. FUNCTION InputStr(VAR S:String;X,Y,Len:LONGINT;TextIn:BOOLEAN;CharAllow:CHARSET):BOOLEAN;
  285. {
  286. Input a string from keyboard, in a nice way,
  287. allowed characters are in CHARSET CharAllow, but several editting
  288. keys are always allowed, see CASE loop.
  289. Parameters:
  290. X,Y Coordinates field
  291. Len Length field
  292. TextIn S already filled?}
  293. VAR
  294. InGev : LONGINT; { No. of chars inputted }
  295. Posi : LONGINT; { Cursorposition}
  296. Ins : BOOLEAN; { Insert yes/no}
  297. Key : LONGINT; { Last key as ELib.GetKey
  298. code <255 if normal key,
  299. >256 if special/function
  300. key. See keys.inc}
  301. Uitg : String; {The inputted string}
  302. Full : BOOLEAN; { Is the string full? }
  303. EndVal : WORD;
  304. PROCEDURE ReWr; { Rewrite the field, using Uitg}
  305. VAR I : LONGINT; { Temporary variabele }
  306. BEGIN
  307. IF Length(Uitg)>Len THEN
  308. Uitg[0]:=CHR(Len);
  309. IF Length(Uitg)>0 THEN
  310. FOR I:= 1 TO Length(Uitg) DO
  311. BEGIN
  312. GotoXY(X+I-1,Y);
  313. IF Uitg[I]=CHR(32) THEN
  314. Write(FieldSpace)
  315. ELSE
  316. Write(Uitg[I]);
  317. END;
  318. IF Len<>Length(Uitg) THEN
  319. BEGIN
  320. GotoXY(X+Length(Uitg),Y);
  321. FOR I:= Length(Uitg) TO Len-1 DO
  322. Write(FieldSpace);
  323. END;
  324. END;
  325. PROCEDURE DoCursor; { Put Cursor in/out insert-mode }
  326. BEGIN
  327. {$IFNDEF Linux}
  328. { IF Ins THEN
  329. SetCursorSize($11E)
  330. ELSE
  331. SetCursorSize($71E); }
  332. {$ENDIF}
  333. END;
  334. BEGIN
  335. { Init }
  336. InGev :=0; { 0 chars untill now }
  337. Posi :=1; { Cursorposition 0 }
  338. Ins :=TRUE; { Insert according to parameters }
  339. DoCursor; { Set cursor accordingly }
  340. Key :=0;
  341. { put ±±± padded field on screen }
  342. FillChar(Uitg,Len+1,FieldSpace);
  343. Uitg[0]:=CHR(Len);
  344. ReWr;
  345. GotoXY(X,Y);
  346. FillChar(Uitg,Len,32);
  347. UitG[0]:=#0;
  348. IF TextIn THEN
  349. BEGIN
  350. Uitg:=S;
  351. Posi:=Length(Uitg)+1; { Put a predefined }
  352. ReWr; { String on screen if specified }
  353. END;
  354. EndVal:=0;
  355. WHILE EndVal=0 DO
  356. BEGIN
  357. Full:=FALSE;
  358. IF ((Posi)>=Len) THEN
  359. BEGIN
  360. Full:=TRUE;
  361. Posi:=Len;
  362. END;
  363. GotoXY(X+Posi-1,Y);
  364. {$IFNDEF Linux}
  365. {$IFDEF FPC}
  366. CursorOn;
  367. {$ENDIF}
  368. DoCursor;
  369. {$ENDIF}
  370. Key:=GetKey;
  371. {$IFNDEF Linux}
  372. {$IFDEF FPC}
  373. CursorOff;
  374. {$ENDIF}
  375. {$ENDIF}
  376. CASE Key OF
  377. CR : BEGIN
  378. EndVal:=1;
  379. S:=UitG;
  380. END;
  381. ESC : EndVal:=2;
  382. BS : IF Posi>1 THEN { BackSpace }
  383. BEGIN
  384. DEC(Posi);
  385. Delete(Uitg,Posi,1);
  386. DEC(InGev);
  387. ReWr;
  388. END;
  389. KDelete : BEGIN
  390. Delete(Uitg,Posi,1);
  391. DEC(InGev);
  392. ReWr;
  393. END;
  394. ArrR : IF (NOT Full) AND ((Posi-1)<InGev) THEN
  395. BEGIN
  396. INC (Posi);
  397. GotoXY(X+Posi-1,Y);
  398. END;
  399. KInsert : BEGIN
  400. Ins:= NOT Ins;
  401. DoCursor;
  402. END;
  403. ArrL : IF (NOT (Posi=1)) THEN
  404. BEGIN
  405. DEC (Posi);
  406. GotoXY(X+Posi-1,Y);
  407. END;
  408. Home : Posi:=1;
  409. KEnd : Posi:=InGev-1;
  410. CtrlY : BEGIN
  411. Delete(Uitg,Posi,Length(Uitg)-Posi);
  412. ReWr;
  413. END;
  414. CtrlT : BEGIN
  415. Uitg[0]:=#0; Posi:=1; ReWr;
  416. END;
  417. END; {Case}
  418. IF EndVal=0 THEN
  419. BEGIN
  420. IF (CHR(Key) IN CharAllow) THEN
  421. BEGIN
  422. IF Posi>Len THEN
  423. Posi:=Len;
  424. IF (Ins=FALSE) OR Full THEN
  425. BEGIN
  426. IF (ORD(Uitg[0])<Posi) THEN
  427. Uitg[0]:=CHR(Posi);
  428. Uitg[Posi]:=CHR(Key);
  429. END
  430. ELSE
  431. BEGIN
  432. Insert(CHR(Key),Uitg,Posi);
  433. END;
  434. ReWr;
  435. INC(Posi);
  436. END;
  437. END;
  438. InGev:=Length(Uitg);
  439. END;
  440. InputStr:=Endval=1;
  441. END;
  442. {$ENDIF}
  443. {$IFDEF UseGraphics}
  444. FUNCTION GrInputStr(VAR S:String;X,Y,Len,dX,dY:LONGINT;TextIn:BOOLEAN;CharAllow:CHARSET):BOOLEAN;
  445. {As the (older) textversion except:
  446. - oX,oY are in pixels.
  447. - dX,dY are the dimensions of the font.
  448. - Len is still characters ( length in pixels/dX)
  449. }
  450. VAR
  451. InGev : LONGINT; { No. of chars inputted }
  452. Posi : LONGINT; { Cursorposition}
  453. Ins : BOOLEAN; { Insert yes/no}
  454. Key : LONGINT; { Last key as ELib.GetKey
  455. code <255 if normal key,
  456. >256 if special/function
  457. key. See keys.inc}
  458. Uitg : String; {The inputted string}
  459. Full : BOOLEAN; { Is the string full? }
  460. EndVal : WORD;
  461. PROCEDURE ReWr; { Rewrite the field, using Uitg}
  462. VAR I : LONGINT; { Temporary variabele }
  463. S : String;
  464. BEGIN
  465. FillChar(S[1],Len,FieldSpace);
  466. S:=Uitg;
  467. IF Length(Uitg)>Len THEN
  468. SetLength(Uitg,Len);
  469. SetLength(S,Len);
  470. IF Length(S)>0 THEN
  471. BEGIN
  472. FOR I:= 1 TO Length(S) DO
  473. IF S[I]=CHR(32) THEN
  474. S[I]:=FieldSpace;
  475. SetFillStyle(SolidFill,0);
  476. Bar(X,Y,X+Len*Dx+5,Y+Dy+1);
  477. OutTextXY(X,Y,S);
  478. END;
  479. END;
  480. PROCEDURE DoCursor; { Put Cursor in/out insert-mode }
  481. BEGIN
  482. {$IFNDEF Linux}
  483. { IF Ins THEN
  484. SetCursorSize($11E)
  485. ELSE
  486. SetCursorSize($71E); }
  487. {$ENDIF}
  488. END;
  489. BEGIN
  490. { Init }
  491. InGev :=0; { 0 chars untill now }
  492. Posi :=1; { Cursorposition 0 }
  493. Ins :=TRUE; { Insert according to parameters }
  494. DoCursor; { Set cursor accordingly }
  495. Key :=0;
  496. // SetFillStyle(SolidFill,0);
  497. // Bar(X,Y,X+Len*Dx+5,Y+Dy+1);
  498. { put ±±± padded field on screen }
  499. FillChar(Uitg,Len+1,FieldSpace);
  500. Uitg[0]:=CHR(Len);
  501. ReWr;
  502. // GotoXY(X,Y);
  503. FillChar(Uitg,Len,32);
  504. SetLength(UitG,0);
  505. IF TextIn THEN
  506. BEGIN
  507. Uitg:=S;
  508. Posi:=Length(Uitg)+1; { Put a predefined }
  509. ReWr; { String on screen if specified }
  510. END;
  511. EndVal:=0;
  512. WHILE EndVal=0 DO
  513. BEGIN
  514. Full:=FALSE;
  515. IF ((Posi)>=Len) THEN
  516. BEGIN
  517. Full:=TRUE;
  518. Posi:=Len;
  519. END;
  520. {$IFNDEF Linux}
  521. {$IFDEF FPC}
  522. CursorOn;
  523. {$ENDIF}
  524. DoCursor;
  525. {$ENDIF}
  526. Key:=GetKey;
  527. {$IFNDEF Linux}
  528. {$IFDEF FPC}
  529. CursorOff;
  530. {$ENDIF}
  531. {$ENDIF}
  532. CASE Key OF
  533. CR : BEGIN
  534. EndVal:=1;
  535. S:=UitG;
  536. END;
  537. ESC : EndVal:=2;
  538. BS : IF Posi>1 THEN { BackSpace }
  539. BEGIN
  540. DEC(Posi);
  541. Delete(Uitg,Posi,1);
  542. DEC(InGev);
  543. ReWr;
  544. END;
  545. KDelete : BEGIN
  546. Delete(Uitg,Posi,1);
  547. DEC(InGev);
  548. ReWr;
  549. END;
  550. ArrR : IF (NOT Full) AND ((Posi-1)<InGev) THEN
  551. BEGIN
  552. INC (Posi);
  553. // GotoXY(X+Posi-1,Y);
  554. END;
  555. KInsert : BEGIN
  556. Ins:= NOT Ins;
  557. DoCursor;
  558. END;
  559. ArrL : IF (NOT (Posi=1)) THEN
  560. BEGIN
  561. DEC (Posi);
  562. END;
  563. Home : Posi:=1;
  564. KEnd : Posi:=InGev-1;
  565. CtrlY : BEGIN
  566. Delete(Uitg,Posi,Length(Uitg)-Posi);
  567. ReWr;
  568. END;
  569. CtrlT : BEGIN
  570. Uitg[0]:=#0; Posi:=1; ReWr;
  571. END;
  572. END; {Case}
  573. IF EndVal=0 THEN
  574. BEGIN
  575. IF (CHR(Key) IN CharAllow) THEN
  576. BEGIN
  577. IF Posi>Len THEN
  578. Posi:=Len;
  579. IF (Ins=FALSE) OR Full THEN
  580. BEGIN
  581. IF (Length(Uitg)<Posi) THEN
  582. SetLength(UitG,Posi);
  583. Uitg[Posi]:=CHR(Key);
  584. END
  585. ELSE
  586. Insert(CHR(Key),Uitg,Posi);
  587. ReWr;
  588. INC(Posi);
  589. END;
  590. END;
  591. InGev:=Length(Uitg);
  592. END;
  593. GrInputStr:=Endval=1;
  594. END;
  595. {$ENDIF}
  596. PROCEDURE SetDefaultColor;
  597. BEGIN
  598. TextColor(DefColor AND 15);
  599. TextBackground(DefColor SHR 4);
  600. END;
  601. {$IFNDEF FPC}
  602. PROCEDURE SetCursorSize(CurDat:WORD);ASSEMBLER;
  603. ASM
  604. mov ah,1
  605. mov cx,CurDat
  606. int $10
  607. END;
  608. {The two procedures below are standard (and os-independant) in FPC's Crt}
  609. PROCEDURE CursorOn;
  610. BEGIN
  611. SetCursorSize($090A);
  612. END;
  613. PROCEDURE CursorOff;
  614. BEGIN
  615. SetCursorSize($FFFF);
  616. END;
  617. PROCEDURE dosmemfillword(Segx,xofs,Count,Value:WORD); ASSEMBLER;
  618. {VAR A:WORD;
  619. BEGIN
  620. FOR A :=0 TO Count-1 DO
  621. MemW[Seg:xofs+2*A]:=Value;
  622. END;
  623. }
  624. ASM
  625. mov ax,segx
  626. mov es,ax
  627. mov di,xofs
  628. mov cx,count
  629. mov ax,value
  630. rep
  631. stosw
  632. end;
  633. {TYPE VetteArray=ARRAY[0..9999] OF BYTE;}
  634. PROCEDURE dosmemput(Segx,xofs:WORD;VAR Data;Count:WORD); assembler;
  635. {VAR A:WORD;
  636. L:^VetteArray;
  637. BEGIN
  638. L:=@Data;
  639. FOR A :=0 TO Count-1 DO
  640. Mem[Segx:xofs+A]:=L^[A];
  641. END;
  642. }
  643. asm
  644. lds si,Data
  645. mov ax,segx
  646. mov es,ax
  647. mov di,xofs
  648. mov cx,count
  649. rep
  650. movsw
  651. end;
  652. PROCEDURE dosmemget(Segx,xofs:WORD;VAR Data;Count:WORD); ASSEMBLER;
  653. {VAR A:WORD;
  654. L:^VetteArray;
  655. BEGIN
  656. L:=@Data;
  657. FOR A :=0 TO Count-1 DO
  658. L^[A]:=Mem[Segx:xofs+A];
  659. END;
  660. }
  661. asm
  662. les di,Data
  663. mov ax,segx
  664. mov ds,ax
  665. mov si,xofs
  666. mov cx,count
  667. rep
  668. movsw
  669. end;
  670. PROCEDURE FillWord(VAR Data;Count,Value:WORD); ASSEMBLER;
  671. {VAR A :WORD;
  672. L:^VetteArray;
  673. BEGIN
  674. L:=@Data;
  675. FOR A:=0 TO Count-1 DO
  676. Begin
  677. L^[2*A]:=Value AND 255;
  678. L^[2*A+1]:=Value shr 8;
  679. END;
  680. END;}
  681. asm
  682. les di,Data
  683. mov cx,count
  684. mov ax,Value
  685. rep
  686. movsw
  687. end;
  688. FUNCTION GetCursorSize:WORD;ASSEMBLER;
  689. ASM
  690. mov ah,3
  691. xor bh,bh
  692. int $10
  693. mov ax,cx
  694. END;
  695. FUNCTION inportb(portx : word) : byte;
  696. BEGIN
  697. Inportb:=Port[PortX];
  698. END;
  699. PROCEDURE outportb(portx : word;data : byte);
  700. BEGIN
  701. Port[portx]:=Data;
  702. END;
  703. FUNCTION inportw(portx : word) : word;
  704. BEGIN
  705. Inportw:=Portw[PortX];
  706. END;
  707. PROCEDURE outportw(portx : word;data : word);
  708. BEGIN
  709. PortW[portx]:=Data;
  710. END;
  711. FUNCTION inportl(portx : word) : longint; ASSEMBLER;
  712. ASM
  713. mov dx,portx { load port address }
  714. db $66; in ax,dx { in eax,dx }
  715. db $66; mov dx,ax { mov edx, eax }
  716. db $66; shr dx,16 { shr edx, 16 }
  717. { return: ax=low word, dx=hi word }
  718. END;
  719. PROCEDURE outportl(portx : word;data : longint); ASSEMBLER;
  720. ASM
  721. { we cant use the 32 bit operand prefix for loading the longint -
  722. therefore we have to do that in two chunks }
  723. mov dx, portx
  724. db $66; mov ax, Word(Data) { mov eax, Data }
  725. db $66; out dx,ax { out dx, eax }
  726. END;
  727. {$ENDIF}
  728. BEGIN
  729. DefColor:=TextAttr; { Save the current attributes, to restore}
  730. Negative:=FALSE; { Negative=true-> better scores are lower}
  731. END.
  732. {
  733. $Log$
  734. Revision 1.6 2000-01-21 00:44:51 peter
  735. * remove unused vars
  736. * renamed to .pp
  737. Revision 1.5 2000/01/14 22:03:43 marco
  738. * Change Lee's first name to John :-)
  739. Revision 1.4 2000/01/01 14:54:16 marco
  740. * Added bp comtibility
  741. :wq
  742. * bp compat routines
  743. B
  744. B
  745. B
  746. Revision 1.3 1999/12/31 17:05:25 marco
  747. Graphical version and fixes. BP cursorroutines moved from FPCTRIS
  748. Revision 1.2 1999/06/11 12:51:29 peter
  749. * updated for linux
  750. Revision 1.1 1999/06/01 19:24:33 peter
  751. * updates from marco
  752. }