DEADSOFTWARE

Remove ascii crap
[cavecraft.git] / src / console.pas
1 unit console;
3 interface
4 const
5 version = 'BETA 9 DEV B12';
7 var
8 osadki:boolean;
9 bl_upd:integer;
10 s_get_drp:boolean;
11 drw_back:boolean;
12 drw_sm:boolean;
13 s_max_fps:integer;
14 s_jpeg_quality:integer;
15 drawgui:boolean;
16 light_type:integer;
18 ifosad:boolean;
20 load_sm:integer;
21 load_sky_siz:integer;
22 load_back_tex:boolean;
23 load_weather_tex:boolean;
24 load_light_tex:boolean;
25 load_gui_tex:boolean;
27 menu_background:integer;
29 load_minimap_tex:boolean;
31 //load_key_tex:integer;
33 drw_stars:boolean;
35 cheats:boolean;
37 sd:string;
39 EOFstr, ENDstr:boolean;
41 procedure save_settings;
42 procedure load_settings;
43 procedure call_console;
44 procedure exec(s, search:string);
45 procedure addToLog(str:string);
47 implementation
49 uses
50 keyboard,
51 vars,
52 maps,
53 canvas,
54 mobs,
55 worldgen,
56 jsr75i,
57 particles,
58 func,
59 player,
60 sensor,
61 drop,
62 inv,
63 furnace,
64 items_store,
65 video;
67 const
68 CON_LOG_SIZE=9;
69 PARSER_MAX_STR=15;
70 MAX_IMGREG=2;
72 var
73 logSTR: array [0..CON_LOG_SIZE] of string;
74 lastCommand:string;
76 parseStr:string;
78 stack: array [0..0] of integer;
79 stack_pointer:integer;
81 regimg:image;
83 procedure resetStack(size:integer);
84 begin
85 stack_pointer:=0;
86 size:=size+1;
87 bytecode
88 iload 0;
89 newarray 10;
90 putstatic field 'console', 'stack', '[I';
91 end;
92 end;
94 procedure pushStack(i:integer;);
95 begin
96 stack[stack_pointer]:=i;
97 stack_pointer:=stack_pointer+1;
98 end;
100 function popStack:integer;
101 begin
102 stack_pointer:=stack_pointer-1;
103 popStack:=stack[stack_pointer];
104 end;
106 procedure swapStack;
107 var
108 tmp:integer;
109 begin
110 tmp:=stack[stack_pointer-2];
111 stack[stack_pointer-2]:=stack[stack_pointer-1];
112 stack[stack_pointer-1]:=tmp;
113 end;
115 procedure dupStack;
116 begin
117 stack[stack_pointer]:=stack[stack_pointer-1];
118 stack_pointer:=stack_pointer+1;
119 end;
121 procedure resetTmpImg;
122 var
123 nullimg:image;
124 begin
125 regimg:=nullimg;
126 end;
128 procedure addToLog(str:string);
129 var
130 i:integer;
131 begin
132 debug('::'+str);
133 for i:=CON_LOG_SIZE-1 downto 0 do
134 logSTR[i+1]:=logSTR[i];
135 logSTR[0]:=str;
136 end;
138 procedure setTexture(img:image; name:string; i:integer);
139 begin
140 name:=UpCase(name);
141 if name='BLOCK' then
142 begin
143 tex[i]:=img;
144 tex8[i]:=resize_image(img, 8, 8);
145 end;
146 else
147 if name='ITEM' then
148 begin
149 item[i]:=img;
150 item8[i]:=resize_image(img, 8, 8);
151 end;
152 else
153 if name='VKEY' then
154 setVkeyImg(img, i);
155 else
156 addToLog('Error: unknown texture type "'+name+'"');
157 end;
159 procedure save_settings;
160 var
161 rs:recordstore;
162 t:integer;
163 begin
164 deleteRecordStore('S');
165 rs:=openRecordStore('S');
166 t:=addRecordStoreEntry(rs,version);
167 t:=addRecordStoreEntry(rs,''+light_type);
168 t:=addRecordStoreEntry(rs,''+ifosad);
169 t:=addRecordStoreEntry(rs, '' + Particles.enabled);
170 t:=addRecordStoreEntry(rs,''+drawgui);
171 t:=addRecordStoreEntry(rs,''+s_jpeg_quality);
172 t:=addRecordStoreEntry(rs,''+load_key_tex);
173 closeRecordStore(rs);
174 end;
176 function sett_ld_bool(s:string):boolean;
177 begin
178 if s='true' then sett_ld_bool:=true;
179 end;
181 procedure load_settings;
182 var
183 rs:recordstore;
184 begin
185 rs:=openRecordStore('S');
186 if readRecordStoreEntry(rs,1)<>version then
187 begin
188 debug(readRecordStoreEntry(rs,1));
189 closeRecordStore(rs);
190 exit;
191 end;
192 light_type:=stringtointeger(readRecordStoreEntry(rs,2));
193 ifosad:=sett_ld_bool(readRecordStoreEntry(rs,3));
194 Particles.enabled := sett_ld_bool(readRecordStoreEntry(rs, 4));
195 drawgui:=sett_ld_bool(readRecordStoreEntry(rs,5));
196 s_jpeg_quality:=stringtointeger(readRecordStoreEntry(rs,6));
197 load_key_tex:=stringtointeger(readRecordStoreEntry(rs,7));
198 closeRecordStore(rs);
199 end;
201 function isEOS(c:integer):boolean;
202 var
203 ch:char;
204 begin
205 ch:=chr(c);
206 if (ch=#$0A) or (ch=#$0D) then
207 isEOS:=true;
208 end;
210 function isSpace(c:integer;):boolean;
211 var
212 ch:char;
213 begin
214 ch:=chr(c);
215 if ((ch=' ') or (ch=#$09) or (ch=#$0B) or isEOS(c)) then
216 isSpace:=true;
217 end;
219 function nextByte(res:resource):integer;
220 var
221 i:integer;
222 begin
223 i:=ReadByte(res);
224 if i=EOF then
225 EOFstr:=true;
226 if isEOS(i) then
227 ENDstr:=true;
229 nextByte:=i and $FF;
230 end;
232 function ReadString(res:resource):string;
233 var
234 b:integer;
235 tmpstr:string;
236 begin
237 ENDstr:=false;
238 repeat
239 b:=nextByte(res);
240 if EOFstr or ENDstr then
241 break;
243 tmpstr:=tmpstr+chr(b);
244 forever;
245 ReadString:=tmpstr;
246 end;
248 function nextChar:integer;
249 var
250 i:integer;
251 begin
252 ENDstr:=false;
253 if length(parseStr)>0 then
254 begin
255 i:=ord(getChar(parseStr, 0));
256 parseStr:=copy(parseStr, 1, length(parseStr));
257 if isEOS(i) then
258 ENDstr:=true;
259 end;
260 else
261 begin
262 parseStr:='';
263 ENDstr:=true;
264 end;
266 nextChar:=i;
267 end;
269 procedure clearSpaces;
270 var
271 i:integer;
272 begin
273 repeat
274 i:=nextChar;
275 if ENDstr then
276 exit;
278 {Symbol ';' is one line commentary}
279 if i=$3B then
280 begin
281 repeat
282 i:=nextChar;
283 if ENDstr then
284 exit;
285 forever;
286 end;
288 if isSpace(i)=false then
289 begin
290 //Go back
291 parseStr:=chr(i)+parseStr;
292 exit;
293 end;
294 forever;
295 end;
297 function nextWord:string;
298 var
299 str:string;
300 i:integer;
301 begin
302 ENDstr:=false;
303 clearSpaces;
304 repeat
305 i:=nextChar;
307 if ENDstr then
308 begin
309 nextWord:=str;
310 exit;
311 end;
313 if isSpace(i) then
314 begin
315 //Go back
316 parseStr:=chr(i)+parseStr;
317 nextWord:=str;
318 exit;
319 end;
320 else
321 str:=str+chr(i);
322 forever;
323 end;
325 function strToBool(str:string):boolean;
326 begin
327 str:=UpCase(str);
328 if str='TRUE' then
329 strToBool:=true;
330 else
331 if str='FALSE' then
332 strToBool:=true;
333 else
334 if StringToInteger(str)<>0 then
335 strToBool:=true;
336 else
337 strToBool:=false;
338 end;
340 //Перевод строки в целое число. base - система счисления
341 function Str2Dec(str:string; base:integer;):integer;
342 var
343 i, tmp, res:integer;
344 ch:char;
345 neg:boolean;
346 begin
347 str:=UpCase(str);
348 if GetChar(str, 0)='-' then
349 begin
350 neg:=true;
351 i:=i+1;
352 end;
354 for i:=i to length(str)-1 do
355 begin
356 ch:=GetChar(str, i);
357 if ((ch>='0') and (ch<='9')) then
358 tmp:=ord(ch)-$30;
359 else
360 if ((ch>='A') and (ch<=chr($36+base))) then
361 tmp:=ord(ch)-$37;
362 else
363 begin
364 addToLog('Error! I cant decode "'+str+'" -> "'+ch+'"');
365 Str2Dec:=0;
366 exit;
367 end;
369 res:=res*base+tmp;
370 end;
372 if neg then
373 Str2Dec:=-res;
374 else
375 Str2Dec:=res;
376 end;
378 function getVar(name:string):integer;
379 begin
380 name:=UpCase(name);
382 if name='SCREEN_W' then
383 getVar:=getWidth;
384 else
385 if name='SCREEN_H' then
386 getVar:=getHeight;
387 else
388 addToLog('Unknown variable "'+name+'"');
389 end;
391 procedure setVar(name:string; value:integer);
392 begin
393 name:=UpCase(name);
395 addToLog('I cant set variable "'+name+'"');
396 end;
398 function DecodeInt(str:string):integer;
399 var
400 head:char;
401 num:string;
402 begin
403 if str='' then
404 begin
405 addToLog('DecodeInt getted null string!');
406 DecodeInt:=0;
407 exit;
408 end;
410 str:=UpCase(str);
411 head:=getchar(str, 0);
412 num:=copy(str, 1, length(str));
414 if str='TRUE' then
415 DecodeInt:=1;
416 else
417 if str='FALSE' then
418 DecodeInt:=0;
419 else
420 if str='POP' then
421 DecodeInt:=popStack;
422 else
423 if head='$' then
424 DecodeInt:=getVar(num);
425 else
426 if (head='0') and (getchar(str, 1)='X') then
427 begin
428 DecodeInt:=Str2Dec(copy(str, 2, length(str)), 16);
429 end;
430 else
431 if (head='0') and (length(str)>1) then
432 begin
433 DecodeInt:=Str2Dec(num, 8);
434 end;
435 else
436 if head='B' then
437 begin
438 DecodeInt:=Str2Dec(num, 2);
439 end;
440 else
441 if ((head>='0') and (head<='9')) or (head='-') then
442 begin
443 DecodeInt:=Str2Dec(str, 10);
445 end;
446 else
447 addToLog('Error! I cant decode "'+str+'"');
448 end;
450 procedure exeCommand(str:string);
451 var
452 com, tmp, tmp2:string;
453 i:integer;
454 begin
455 parseStr:=str;
456 clearSpaces;
457 if parseStr='' then
458 exit;
460 com:=UpCase(nextWord);
462 if (cheats) or (gamemode=1) then
463 begin
464 if com='TIME' then
465 game_time:=decodeInt(nextWord);
466 else
467 if com='FLY' then
468 fly:=strToBool(nextWord);
469 else
470 if com='PL_HP' then
471 hp:=decodeInt(nextWord);
472 else
473 if com='PL_EP' then
474 hunger:=decodeInt(nextWord);
475 else
476 if com='GIVE' then
477 player.dropItem(decodeInt(nextWord), decodeInt(nextWord));
478 else
479 if com='PL_TP' then
480 begin
481 player.setX(decodeInt(nextWord));
482 player.setY(decodeInt(nextWord));
483 end;
484 else
485 if com='GAMEMODE' then
486 begin
487 gamemode:=decodeInt(nextWord);
488 fly:=false;
489 end;
490 else
491 if com='SPAWN' then
492 begin
493 player.setX(get_spawn_x*16+4);
494 player.setY(get_spawn_y*16);
495 end;
496 else
497 {if com='SPAWN_MOBS' then
498 s_spawn_mob:=strToBool(nextWord);
499 else}
500 {if com='SURVIVAL' then
501 begin
502 fly:=false;
503 gamemode:=0;
504 hp:=20;
505 hunger:=20;
506 for i:=0 to 35 do
507 begin
508 inv[i].item_i:=0;
509 inv[i].sum_i:=0;
510 end;
511 end;
512 else}
513 if com='CLEAR_INVENTORY' then
514 begin
515 inv.resetData;
516 end;
517 else
519 end;
521 if com='I_AM_CHEATER' then
522 begin
523 if nextWord=#$36+#$36+#$36 then
524 cheats:=not cheats;
525 else
526 cheats:=false;
527 end;
528 else
529 if com='HALT' then
530 halt;
531 else
532 if com='WEATHER' then
533 osadki:=strToBool(nextWord);
534 else
535 {if com='MEGASPAWN' then
536 megaspawn;
537 else}
538 if com='REF_DRP' then
539 ref_drp:=strToBool(nextWord);
540 else
541 if com='BL_UPD' then
542 bl_upd:=decodeInt(nextWord);
543 else
544 if com='GET_DRP' then
545 s_get_drp:=strToBool(nextWord);
546 else
547 if com='MAX_FPS' then
548 s_max_fps:=decodeInt(nextWord); else
549 if com='DRW_BACK' then
550 drw_back:=strToBool(nextWord);
551 else
552 {if com='DRW_MOBS' then
553 drw_mobs:=strToBool(nextWord);
554 else}
555 if com='DRP_PHY' then
556 drp_phy:=strToBool(nextWord);
557 else
558 if com='DRW_SM' then
559 drw_sm:=strToBool(nextWord);
560 else
561 if com='JPEG_Q' then
562 begin
563 s_jpeg_quality:=decodeInt(nextWord);
564 if s_jpeg_quality>100 then
565 s_jpeg_quality:=100;
566 else if s_jpeg_quality<0 then
567 s_jpeg_quality:=0;
568 end;
569 else
570 if com='LOAD_SM' then
571 load_sm:=decodeInt(nextWord);
572 else
573 if com='S_WEATHER' then
574 ifosad:=strToBool(nextWord);
575 else
576 if com='S_HIDE_GUI' then
577 drawgui:=strToBool(nextWord);
578 else
579 if com='S_LIGHT' then
580 light_type:=decodeInt(nextWord);
581 else
582 if com='S_PARTICLES' then
583 Particles.enabled := strToBool(nextWord);
584 else
585 if com='LOAD_SKY' then
586 load_sky_siz:=decodeInt(nextWord);
587 else
588 {if com='LOAD_MOB_TEX' then
589 load_mob_tex:=strToBool(nextWord);
590 else}
591 if com='LOAD_BACK_TEX' then
592 load_back_tex:=strToBool(nextWord);
593 else
594 if com='LOAD_WEATHER_TEX' then
595 load_weather_tex:=strToBool(nextWord);
596 else
597 if com='LOAD_LIGHT_TEX' then
598 load_light_tex:=strToBool(nextWord);
599 else
600 if com='LOAD_GUI_TEX' then
601 load_gui_tex:=strToBool(nextWord);
602 else
603 if com='MENU_BACKGROUND' then
604 menu_background:=decodeInt(nextWord);
605 else
606 if com='DRW_DRP' then
607 drw_drp:=strToBool(nextWord);
608 else
609 if com='DRW_STARS' then
610 drw_stars:=strToBool(nextWord);
611 else
612 if com='SV_SETT' then
613 save_settings;
614 else
615 if com='LD_SETT' then
616 load_settings;
617 else
618 if com='LOAD_MINIMAP_TEX' then
619 load_minimap_tex:=strToBool(nextWord);
620 else
621 if com='EXEC' then
622 begin
623 tmp:=nextWord;
624 exec(nextWord, tmp);
625 end;
626 else
627 if com='RESET_FUELS' then
628 begin
629 furnace.setMaxFuel(decodeInt(nextWord));
630 //addToLog('Max fuel: '+decodeInt(parsed_str[1]));
631 end;
632 else
633 if com='SET_FUEL' then
634 begin
635 furnace.initFuel(decodeInt(nextWord),
636 decodeInt(nextWord),
637 decodeInt(nextWord));
638 end;
639 else
640 if com='RESET_RECIPES' then
641 begin
642 furnace.setMaxRecipes(decodeInt(nextWord));
643 //addToLog('Max recipes: '+decodeInt(parsed_str[1]));
644 end;
645 else
646 if com='SET_RECIPE' then
647 begin
648 furnace.initRecipe(decodeInt(nextWord),
649 decodeInt(nextWord),
650 decodeInt(nextWord));
651 end;
652 else
653 if com='RESET_CRAFTS' then
654 begin
655 resetCrafts(decodeInt(nextWord));
656 //addToLog('Max crafts: '+decodeInt(parsed_str[1]));
657 end;
658 else
659 if com='SET_CRAFT_IN' then
660 begin
661 setCraftIn(decodeInt(nextWord),
662 decodeInt(nextWord),
663 decodeInt(nextWord),
664 decodeInt(nextWord));
665 end;
666 else
667 if com='SET_CRAFT_OUT' then
668 begin
669 setCraftOUT(decodeInt(nextWord),
670 decodeInt(nextWord),
671 decodeInt(nextWord),
672 decodeInt(nextWord));
673 end;
674 else
675 if com='RESET_BLOCKS_TEX' then
676 begin
677 initBlockTex(decodeInt(nextWord));
678 end;
679 else
680 if com='RESET_ITEMS_TEX' then
681 begin
682 initItemTex(decodeInt(nextWord));
683 end;
684 else
685 if com='LOAD_TEX' then
686 begin
687 regimg:=ld_tex(nextWord, '/'+sd+'/cavecraft/texturepacks/'+tex_pack+'/', '');
688 end;
689 else
690 if com='RESET_TEX' then
691 resetTmpImg;
692 else
693 if com='SET_TEX' then
694 setTexture(regimg,
695 nextWord,
696 decodeInt(nextWord));
697 if com='SET_CANV_TEX' then
698 begin
699 tmp:=nextWord;
700 tmp2:=nextWord;
701 setTexture(rotate_image_from_image(regimg,
702 decodeInt(nextWord),
703 decodeInt(nextWord),
704 decodeInt(nextWord),
705 decodeInt(nextWord),
706 0),
707 tmp,
708 decodeInt(tmp2));
709 end;
710 else
711 if com='BIND_KEY' then
712 begin
713 tmp:=nextWord;
714 for i:=0 to MAX_KEY_BIND do
715 keyboard.bindKey(decodeInt(tmp), i, decodeInt(nextWord));
716 end;
717 else
718 if com='STACK' then
719 resetStack(decodeInt(nextWord));
720 else
721 if com='PUSH' then
722 pushStack(decodeInt(nextWord));
723 else
724 if com='POP' then
725 i:=popStack;
726 else
727 if com='SWAP' then
728 swapStack;
729 else
730 if com='DUP' then
731 dupStack;
732 else
733 if com='ADD' then
734 pushStack(popStack+popStack);
735 else
736 if com='SUB' then
737 begin
738 i:=popStack;
739 pushStack(popStack-i);
740 end;
741 else
742 if com='MUL' then
743 pushStack(popStack*popStack);
744 else
745 if com='DIV' then
746 begin
747 i:=popStack;
748 pushStack(popStack/i);
749 end;
750 else
751 if com='MOD' then
752 begin
753 i:=popStack;
754 pushStack(popStack mod i);
755 end;
756 else
757 if com='SET' then
758 setVar(nextWord, decodeInt(nextWord));
759 else
760 if com='POPSET' then
761 setVar(nextWord, popStack);
762 else
763 if com='MAX_VKEYS' then
764 resetVirtualKeyboard(decodeInt(nextWord));
765 else
766 if com='SET_VKEY' then
767 bindVKey(decodeInt(nextWord),
768 decodeInt(nextWord),
769 decodeInt(nextWord),
770 decodeInt(nextWord));
771 else
772 if com='SET_RESOLUTION' then
773 initVideo(decodeInt(nextWord), decodeInt(nextWord), strToBool(nextWord));
774 else
775 //addToLog('Unknown command "'+com+'"');
776 end;
778 procedure call_console;
779 var
780 commandTxt:integer;
781 i, tmpid:integer;
782 exitCmd, exeCmd, Clicked:command;
783 str:string;
784 begin
786 setFont(FONT_FACE_SYSTEM,FONT_STYLE_PLAIN,FONT_SIZE_SMALL);
788 repeat
789 ClearForm;
791 exitCmd:=createCommand('Exit', CM_EXIT, 1);
792 exeCmd:=createCommand('Execute', CM_OK, 1);
793 addCommand(exitCmd);
794 addCommand(exeCmd);
796 commandTxt:=formAddTextField('Enter command:', ''+lastCommand, 32, TF_ANY);
798 for i:=0 to CON_LOG_SIZE do
799 tmpid:=formAddString(logSTR[i]+chr(10));
801 ShowForm;
802 Repaint;
804 repeat
805 Clicked:=getClickedCommand;
806 if Clicked=exitCmd then
807 begin
808 lastCommand:=formGetText(commandTxt);
809 showCanvas;
810 exit;
811 end;
812 else
813 if Clicked=exeCmd then
814 begin
815 str:=formGetText(commandTxt);
816 addToLog(str);
817 exeCommand(str);
818 lastCommand:='';
819 break;
820 end;
821 forever;
822 forever;
823 end;
825 procedure exec(s, search:string);
826 var
827 res:resource;
828 str:string;
829 tmpEOF : Boolean;
830 begin
831 search:=UpCase(search);
833 if search='LOCAL' then
834 begin
835 addToLog('Load file "'+s+'" at LOCAL!');
836 res:=OpenResource('/'+s);
837 end;
838 else
839 if search='SD' then
840 begin
841 if open_file('/'+sd+'/cavecraft/'+s)=1 then
842 begin
843 addToLog('Load file "'+s+'" at SD!');
844 res:=get_stream;
845 end;
846 end;
847 else
848 if search='AUTO' then
849 begin
850 addToLog('path "/'+sd+'/cavecraft/'+s+'"');
851 if file_exists('/'+sd+'/cavecraft/'+s)=1 then
852 begin
853 if open_file('/'+sd+'/cavecraft/'+s)=1 then
854 begin
855 addToLog('Load file "'+s+'" at SD(AUTO)!');
856 res:=get_stream;
857 end;
858 end;
859 else
860 begin
861 addToLog('Load file "'+s+'" at LOCAL(AUTO)!');
862 res:=OpenResource('/'+s);
863 end;
864 end;
865 else
866 begin
867 addToLog('Unknown load type "'+search+'", file "'+s+'" not executed!');
868 exit;
869 end;
871 if ResourceAvailable(res) then
872 repeat
873 str:=ReadString(res);
874 tmpEOF:=EOFstr;
875 //addToLog('Exec: "'+str+'"');
876 exeCommand(str);
877 EOFstr:=tmpEOF;
878 until EOFstr;
879 else
880 addToLog('Execute file "'+s+'" not found!');
882 EOFstr := false;
883 ENDstr := false;
884 CloseResource(res);
885 end;
887 initialization
889 end.