gameunit.pp 19 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887
  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 Ver70}
  24. {$define MouseAPI}
  25. {$G+}
  26. {$endif}
  27. {$IFDEF Ver60}
  28. {$define MouseAPI}
  29. {$G+}
  30. {$endif}
  31. {$IFDEF Ver55}
  32. {$define MouseAPI}
  33. {$G+}
  34. {$endif}
  35. CONST LineDistY=13;
  36. TYPE CHARSET=SET OF CHAR;
  37. {---- Unified Mouse procedures. ---- }
  38. FUNCTION MousePresent : BOOLEAN;
  39. PROCEDURE HideMouse;
  40. PROCEDURE ShowMouse;
  41. PROCEDURE GetMouseState(VAR MX,MY,MState : LONGINT);
  42. PROCEDURE DoneMouse;
  43. PROCEDURE InitMouse;
  44. PROCEDURE SetMousePosition(X,Y:LONGINT);
  45. Const LButton = 1; {left button}
  46. RButton = 2; {right button}
  47. MButton = 4; {middle button}
  48. {---- Standard Highscore procedures ----}
  49. TYPE HighScoreType = Packed RECORD
  50. Name : String[15];
  51. Score: LONGINT;
  52. END;
  53. HighScoreArr = ARRAY[0..9] OF HighScoreType;
  54. VAR HighScore : HighScoreArr;
  55. ScorePath : String;
  56. HighX,HighY : LONGINT;
  57. Negative : BOOLEAN; { Negative=true-> better scores are lower}
  58. PROCEDURE LoadHighScore(FileName:STRING);
  59. PROCEDURE SaveHighScore;
  60. PROCEDURE ShowHighScore;
  61. FUNCTION SlipInScore(Score:LONGINT):LONGINT;
  62. {---- Keyboard routines ----}
  63. CONST {Constants for GetKey}
  64. ArrU = $04800; ArrL = $04B00; ArrR = $04D00; BS = $08; (* Backspace *)
  65. ArrD = $05000; CR = $0D; ESC = $1B; KDelete= $05300;
  66. KInsert= $05200; Home = $04700; KEnd = $04F00; CtrlY = $19;
  67. CtrlT = $14;
  68. CONST FieldSpace : CHAR = #177;
  69. AlfaBeta : CHARSET= [' '..'z'];
  70. FUNCTION GetKey:LONGINT;
  71. {Generic string input routine}
  72. {$IFDEF UseGraphics}
  73. FUNCTION GrInputStr(VAR S:String;X,Y,Len,dX,dY:LONGINT;TextIn:BOOLEAN;CharAllow:CHARSET):BOOLEAN;
  74. {$ELSE}
  75. FUNCTION InputStr(VAR S:String;X,Y,Len:LONGINT;TextIn:BOOLEAN;CharAllow:CHARSET):BOOLEAN;
  76. {$ENDIF}
  77. {---- Misc ----}
  78. PROCEDURE SetDefaultColor; {Restore the attribs saved on startup}
  79. {BP compability}
  80. {$IFNDEF FPC}
  81. PROCEDURE SetCursorSize(CurDat:WORD);
  82. FUNCTION GetCursorSize:WORD;
  83. PROCEDURE CursorOn;
  84. PROCEDURE CursorOff;
  85. {Non Go32 but not existant in BP}
  86. PROCEDURE FillWord(VAR Data;Count,Value:WORD);
  87. PROCEDURE dosmemfillword(Segx,xofs,Count,Value:WORD);
  88. PROCEDURE dosmemput(Segx,xofs:WORD;VAR Data;Count:WORD);
  89. PROCEDURE dosmemget(Segx,xofs:WORD;VAR Data;Count:WORD);
  90. FUNCTION inportb(portx : word) : byte;
  91. PROCEDURE outportb(portx : word;data : byte);
  92. FUNCTION inportw(portx : word) : word;
  93. PROCEDURE outportw(portx : word;data : word);
  94. FUNCTION inportl(portx : word) : longint;
  95. PROCEDURE outportl(portx : word;data : longint);
  96. {$ENDIF}
  97. IMPLEMENTATION
  98. {$IFDEF MouseAPI}
  99. {$IFDEF UseGraphics}
  100. Uses Mouse,Dos,Crt,Graph;
  101. {$ELSE}
  102. Uses Mouse,Dos,Crt;
  103. {$ENDIF}
  104. {$ELSE}
  105. {$IFDEF UseGraphics}
  106. Uses MsMouse,Dos,Crt,Graph;
  107. {$ELSE}
  108. Uses MsMouse,Dos,Crt;
  109. {$ENDIF}
  110. {$ENDIF}
  111. VAR DefColor : BYTE; {Backup of startup colors}
  112. CONST
  113. {The initial names. If people feel they are missing, I first checked the Alias,
  114. and then filled with names of the FPC-Devel list, and arranged them alfabetically}
  115. InitNames : ARRAY[0..9] OF String[12] = ('Carl','Daniel','Florian','Jonas','Lee','Marco','Michael (3x)',
  116. 'Peter','Pierre','Thomas' );
  117. {$IFDEF MouseAPI}
  118. VAR MouseBuffer : LONGINT;
  119. {$ENDIF}
  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. { put ±±± padded field on screen }
  497. FillChar(Uitg,Len+1,FieldSpace);
  498. Uitg[0]:=CHR(Len);
  499. ReWr;
  500. // GotoXY(X,Y);
  501. FillChar(Uitg,Len,32);
  502. SetLength(UitG,0);
  503. IF TextIn THEN
  504. BEGIN
  505. Uitg:=S;
  506. Posi:=Length(Uitg)+1; { Put a predefined }
  507. ReWr; { String on screen if specified }
  508. END;
  509. EndVal:=0;
  510. WHILE EndVal=0 DO
  511. BEGIN
  512. Full:=FALSE;
  513. IF ((Posi)>=Len) THEN
  514. BEGIN
  515. Full:=TRUE;
  516. Posi:=Len;
  517. END;
  518. {$IFNDEF Linux}
  519. {$IFDEF FPC}
  520. CursorOn;
  521. {$ENDIF}
  522. DoCursor;
  523. {$ENDIF}
  524. Key:=GetKey;
  525. {$IFNDEF Linux}
  526. {$IFDEF FPC}
  527. CursorOff;
  528. {$ENDIF}
  529. {$ENDIF}
  530. CASE Key OF
  531. CR : BEGIN
  532. EndVal:=1;
  533. S:=UitG;
  534. END;
  535. ESC : EndVal:=2;
  536. BS : IF Posi>1 THEN { BackSpace }
  537. BEGIN
  538. DEC(Posi);
  539. Delete(Uitg,Posi,1);
  540. DEC(InGev);
  541. ReWr;
  542. END;
  543. KDelete : BEGIN
  544. Delete(Uitg,Posi,1);
  545. DEC(InGev);
  546. ReWr;
  547. END;
  548. ArrR : IF (NOT Full) AND ((Posi-1)<InGev) THEN
  549. BEGIN
  550. INC (Posi);
  551. // GotoXY(X+Posi-1,Y);
  552. END;
  553. KInsert : BEGIN
  554. Ins:= NOT Ins;
  555. DoCursor;
  556. END;
  557. ArrL : IF (NOT (Posi=1)) THEN
  558. BEGIN
  559. DEC (Posi);
  560. END;
  561. Home : Posi:=1;
  562. KEnd : Posi:=InGev-1;
  563. CtrlY : BEGIN
  564. Delete(Uitg,Posi,Length(Uitg)-Posi);
  565. ReWr;
  566. END;
  567. CtrlT : BEGIN
  568. Uitg[0]:=#0; Posi:=1; ReWr;
  569. END;
  570. END; {Case}
  571. IF EndVal=0 THEN
  572. BEGIN
  573. IF (CHR(Key) IN CharAllow) THEN
  574. BEGIN
  575. IF Posi>Len THEN
  576. Posi:=Len;
  577. IF (Ins=FALSE) OR Full THEN
  578. BEGIN
  579. IF (Length(Uitg)<Posi) THEN
  580. SetLength(UitG,Posi);
  581. Uitg[Posi]:=CHR(Key);
  582. END
  583. ELSE
  584. Insert(CHR(Key),Uitg,Posi);
  585. ReWr;
  586. INC(Posi);
  587. END;
  588. END;
  589. InGev:=Length(Uitg);
  590. END;
  591. GrInputStr:=Endval=1;
  592. END;
  593. {$ENDIF}
  594. PROCEDURE SetDefaultColor;
  595. BEGIN
  596. TextColor(DefColor AND 15);
  597. TextBackground(DefColor SHR 4);
  598. END;
  599. {$IFNDEF FPC}
  600. PROCEDURE SetCursorSize(CurDat:WORD);ASSEMBLER;
  601. ASM
  602. mov ah,1
  603. mov cx,CurDat
  604. int $10
  605. END;
  606. {The two procedures below are standard (and os-independant) in FPC's Crt}
  607. PROCEDURE CursorOn;
  608. BEGIN
  609. SetCursorSize($090A);
  610. END;
  611. PROCEDURE CursorOff;
  612. BEGIN
  613. SetCursorSize($FFFF);
  614. END;
  615. PROCEDURE dosmemfillword(Segx,xofs,Count,Value:WORD); ASSEMBLER;
  616. {VAR A:WORD;
  617. BEGIN
  618. FOR A :=0 TO Count-1 DO
  619. MemW[Seg:xofs+2*A]:=Value;
  620. END;
  621. }
  622. ASM
  623. mov ax,segx
  624. mov es,ax
  625. mov di,xofs
  626. mov cx,count
  627. mov ax,value
  628. rep
  629. stosw
  630. end;
  631. {TYPE VetteArray=ARRAY[0..9999] OF BYTE;}
  632. PROCEDURE dosmemput(Segx,xofs:WORD;VAR Data;Count:WORD); assembler;
  633. {VAR A:WORD;
  634. L:^VetteArray;
  635. BEGIN
  636. L:=@Data;
  637. FOR A :=0 TO Count-1 DO
  638. Mem[Segx:xofs+A]:=L^[A];
  639. END;
  640. }
  641. asm
  642. lds si,Data
  643. mov ax,segx
  644. mov es,ax
  645. mov di,xofs
  646. mov cx,count
  647. rep
  648. movsw
  649. end;
  650. PROCEDURE dosmemget(Segx,xofs:WORD;VAR Data;Count:WORD); ASSEMBLER;
  651. {VAR A:WORD;
  652. L:^VetteArray;
  653. BEGIN
  654. L:=@Data;
  655. FOR A :=0 TO Count-1 DO
  656. L^[A]:=Mem[Segx:xofs+A];
  657. END;
  658. }
  659. asm
  660. les di,Data
  661. mov ax,segx
  662. mov ds,ax
  663. mov si,xofs
  664. mov cx,count
  665. rep
  666. movsw
  667. end;
  668. PROCEDURE FillWord(VAR Data;Count,Value:WORD); ASSEMBLER;
  669. {VAR A :WORD;
  670. L:^VetteArray;
  671. BEGIN
  672. L:=@Data;
  673. FOR A:=0 TO Count-1 DO
  674. Begin
  675. L^[2*A]:=Value AND 255;
  676. L^[2*A+1]:=Value shr 8;
  677. END;
  678. END;}
  679. asm
  680. les di,Data
  681. mov cx,count
  682. mov ax,Value
  683. rep
  684. movsw
  685. end;
  686. FUNCTION GetCursorSize:WORD;ASSEMBLER;
  687. ASM
  688. mov ah,3
  689. xor bh,bh
  690. int $10
  691. mov ax,cx
  692. END;
  693. FUNCTION inportb(portx : word) : byte;
  694. BEGIN
  695. Inportb:=Port[PortX];
  696. END;
  697. PROCEDURE outportb(portx : word;data : byte);
  698. BEGIN
  699. Port[portx]:=Data;
  700. END;
  701. FUNCTION inportw(portx : word) : word;
  702. BEGIN
  703. Inportw:=Portw[PortX];
  704. END;
  705. PROCEDURE outportw(portx : word;data : word);
  706. BEGIN
  707. PortW[portx]:=Data;
  708. END;
  709. FUNCTION inportl(portx : word) : longint; ASSEMBLER;
  710. ASM
  711. mov dx,portx { load port address }
  712. db $66; in ax,dx { in eax,dx }
  713. db $66; mov dx,ax { mov edx, eax }
  714. db $66; shr dx,16 { shr edx, 16 }
  715. { return: ax=low word, dx=hi word }
  716. END;
  717. PROCEDURE outportl(portx : word;data : longint); ASSEMBLER;
  718. ASM
  719. { we cant use the 32 bit operand prefix for loading the longint -
  720. therefore we have to do that in two chunks }
  721. mov dx, portx
  722. db $66; mov ax, Word(Data) { mov eax, Data }
  723. db $66; out dx,ax { out dx, eax }
  724. END;
  725. {$ENDIF}
  726. BEGIN
  727. {$IFDEF MouseAPI}
  728. MouseBuffer:=0;
  729. {$ENDIF}
  730. DefColor:=TextAttr; { Save the current attributes, to restore}
  731. Negative:=FALSE; { Negative=true-> better scores are lower}
  732. END.
  733. {
  734. $Log$
  735. Revision 1.4 2000-01-01 14:54:16 marco
  736. * Added bp comtibility
  737. :wq
  738. * bp compat routines
  739. B
  740. B
  741. B
  742. Revision 1.3 1999/12/31 17:05:25 marco
  743. Graphical version and fixes. BP cursorroutines moved from FPCTRIS
  744. Revision 1.2 1999/06/11 12:51:29 peter
  745. * updated for linux
  746. Revision 1.1 1999/06/01 19:24:33 peter
  747. * updates from marco
  748. }