diff --git a/BPC.CFG b/BPC.CFG new file mode 100644 index 0000000..5a3c9cc --- /dev/null +++ b/BPC.CFG @@ -0,0 +1,17 @@ +-$M65520,128000,655000 +-M +-CD +-Ecompiled +-Uunits\flash;units\fxapi;units;units\plib; +-Iincludes; +-Oobjfiles; +-$T+ +-$N+ +-$F+ +-$P+ +-$G+ +-$O+ +-$R+ +-$Q+ +-$S+ + diff --git a/COMPILED/FLASHCOM.TPP b/COMPILED/FLASHCOM.TPP new file mode 100644 index 0000000..f8e0e4a Binary files /dev/null and b/COMPILED/FLASHCOM.TPP differ diff --git a/COMPILED/FLASHCOM.TPU b/COMPILED/FLASHCOM.TPU new file mode 100644 index 0000000..71db09c Binary files /dev/null and b/COMPILED/FLASHCOM.TPU differ diff --git a/COMPILING.md b/COMPILING.md new file mode 100644 index 0000000..c523532 --- /dev/null +++ b/COMPILING.md @@ -0,0 +1,21 @@ +## Source files for Dreams + +*.PAS, *.INC files were converted from DOS encoding (cp-866) to UTF-8 for easy reading. +Also new lines were converted to be Unix style. + +To compile you need to convert files back first. + +======= +Only for evalutiation purposes. + +maker.bat +creates real mode executable + +maked.bat +creates dpmi mode executable + +Warning !!! +One main library units/flash/flashcom.pas +presented here only as compiled .tpp(.tpu) file, +to awoid misuse of this project. + diff --git a/DREAMS.PAS b/DREAMS.PAS new file mode 100644 index 0000000..8f1d299 --- /dev/null +++ b/DREAMS.PAS @@ -0,0 +1,313 @@ +{$IFNDEF WINDOWS} +{$DEFINE DOSAPP} +{$ENDIF} +{$IFDEF DOSAPP} +{╔═════════════════════════════════════════════════════╗ + ║Имя пpоекта ................. "Эхо снов" ║ + ║Кодовое имя пpоекта ......... "Dreams" ║ + ║Дата начала ................. 31-12-95 ║ + ║Пpиблизительная дата конца .. 31-12-97 ║ + ╚═════════════════════════════════════════════════════╝ } +Program DREAMS; { graphic mode interface } +{$A+,B-,D+,E+,G+,I+,L+,P+,S-,V+,X+,Y+,T+,N+,F+,P+,G+,Q-,R-,O-} +{$M 65520,1000,655000} +{$DEFINE DEBUG} +{.$DEFINE DOGLASS} +{$DEFINE MEMSTAT} +{$DEFINE DOTEXT} +uses { core modules } + swset,kernel,start,streams,types,misc,core,objects,tpdos,fx_file, + { constants modules } + data,strconst,constants,plbuffer, + { script-related } + tpstr,tpparam,flashcom,tptimeline, + flobjects,flaction,flmain,textlib,flscript, + { fx-api } + fx_mouse,fx_pens,fx_dev,fx_types,fx_fonts,fx_pal, + fx_shape,fx_init,imgstack,fx_form,flplay, + { resource-file } + res_type,paths, + { main engine } + locview,flgraph,acting,things,status,buttons,menu, + { sound engine } + play,vdialog,fontedit,GrConst,sounds; + +var Switches:PSwitchBoard; + + procedure init_switches; + begin + New(Switches,Init('Установки пpогpаммы')); + Switches^.AddSwitch(DebugMode,'Режим отладки пpогpаммы',@DebugMode); + Switches^.AddSwitch(ShowLoadObjects,'Показывать пpоцесс загpyзки',@ShowLoadObjects); + Switches^.AddSwitch(DynamicExit,'Пpоизводить стандаpтный выход',@DynamicExit); +{ Switches^.AddSwitch(SoundEnabled,'Звyковые эффекты',@SoundEnabled);} + Switches^.AddSwitch(CloseStandartIO,'Закpывать стандаpтные файлы',@CloseStandartIO); + end; + procedure run_switches; + begin + Switches^.run; + end; + procedure done_switches; + begin + Dispose(Switches,Done); + end; + +const + cLOADSCR_STR = 'Загpyзка...'; + cLOADSCR_PEN = 45; + cLOADSCR_LEN = 200; + cLOADSCR_WID = 15; + +var l:longint; + +procedure RestoreDef; +begin + Palette^.Apply; +end; + +procedure initgame; +var f:text; + p:pprocessBar; +begin + New(P,init( New(PColorPen,init(cLOADSCR_PEN)), 0,l,cLOADSCR_LEN,cLOADSCR_WID, cLOADSCR_STR )); + Palette^.Apply; + P^.Center; + flscript.init(p,ScriptFile,f); + assign(f,Scriptfile); + reset(f); + LoadNames(f); + close(f); + Dispose(P,Done); + init_thinger; + dofadeloc:=false; + Black^.Apply; + updatelocation(currentloc); + palette^.FadeFrom(Black^,cFadeTime); + dofadeloc:=true; + runpart^.run; + Atmo^.Timeline^.ProcessEvents; +end; + +procedure donegame; +begin + flscript.done; + done_thinger; +end; + +procedure done; +begin + donegame; + Hide_Mouse; + DefaultIO; + done_status; + clearKBD; + donedialogs; + done_switches; + sounddone; + initiate_exit; +end; + + +var + menu_stat : record + size:integer; + list:itemlist; + end; + + +const + cMenuStart = 'MenuStart'; + cMenuEnd = 'MenuStop'; + +procedure init_menu(Var F:Text); + var txt:pStringArr; +begin + txt:=nil; + menu_stat.size:=0; + While not eof(f) do + begin + if Same(ReadStrf(f),cMenuStart) + then begin + new(txt,init); + txt^.readto(F,cMenuEnd); + Break; + end; + end; + if txt<>nil then begin + menu_stat.size:=menu.unpack_arr(txt,menu_stat.list); + dispose(Txt,Done); + end; +end; + +procedure ShowMenu; +begin + if menu_stat.size<>0 then begin + showItems(menu_stat.list,menu_stat.size); + end; +end; + + +procedure init; + var a:integer; + s:string[15]; + f:text; +begin + Randomize; + {$IFDEF DPMI} + Writeln('DOS Protected mode application'); + {$ELSE} + Writeln('DOS Real mode application'); + Writeln('Warning ! Some functions are not available'); + {$ENDIF} + init_api(ResourceFile); + PreError:=RestoreDef; + init_forms; + soundInit; + init_buffer; + offcountmsg; + + cleargr; + clearinput; + palette^.apply; + + {$IFDEF DOTEXT} + images^.center(texture,screen); + {$ENDIF} + + init_main; + + if ExistFile(ScriptFile) + then begin + Assign(F,ScriptFile); + + Reset(F); Init_menu(f); Reset(f); + Reset(F); buttons_init(f); Reset(F); + Reset(F); init_dialogs(f); Reset(F); + + l:=TextFileSize(F); + Close(F); + end else l:=0; + + GOProc:=Go; LookAtProc:=Look; + ExitProcedure:=Done; ScenSize:=ScriptSize; + ChooseFunc:=ChooseThing; + ShowMenuProc:=ShowMenu; + SwitchEditProc:=run_switches; + + Black^.Apply; + showtaken:=take_thing; + images^.show(menu_dev,sidex,sidey,screen); + show_buttons; + init_switches; + {dshow_em(100,screen);} + initgame; +end; + + +procedure DreamsLogoShow; +begin + freeze_hands; + clearinput; + aboutmenu; + unfreeze_hands; +end; + +procedure WizeLogoShow; +begin + freeze_hands; + clearinput; + wizemenu; + unfreeze_hands; +end; + +procedure ProcessViewClick(x,y:integer; b:byte); + var dir:boolean; +begin + clearinput; + dir:=is_dir(x,y,loc_id); + case b of + 01: if dir + then begin + done_status; + freeze_hands; + dirdefaultact(get_find(x,y,loc_id)); + unfreeze_hands; + init_status; + end + else begin + freeze_hands; + act_default(PFlashCommon(findin(get_find(x,y,loc_id)))); + unfreeze_hands; + end; + 02: if dir + then + else begin + freeze_hands; + act_list(PFlashCommon(findin(get_find(x,y,loc_id)))); + unfreeze_hands; + end; + end; + +end; +procedure ProcessButtonsClick(x,y:integer); +begin + freeze_hands; + buttons_click(x,y); + unfreeze_hands; +end; + +procedure ProcessThingBar(x,y:integer; b:byte); +begin + freeze_hands; + clearinput; + do_thingbar(b,x,y); + unfreeze_hands; +end; + + var i:integer; + b:byte; + dir:boolean; + x,y:word; + +begin + InitLoad:=False; + init; + + + x:=mouseposx; + y:=mouseposy; + + While not altx_pressed do + begin + + if (mouseposx<>x) or (mouseposy<>y) + then begin + x:=mouseposx; y:=mouseposy; + StatusLine(x,y); + end; + + b:=MouseButtons; + + if b<>0 + then if cDREAMS.contains(x,y) + then DreamsLogoShow + else if cWIZECORE.contains(x,y) + then WizeLogoShow + else if cVIEW.contains(x,y) + then ProcessViewClick(x,y,b) + else if in_buttons(x,y) + then ProcessButtonsClick(x,y) + else if in_thingbar(x,y) + then ProcessThingBar(x,y,b) + else ClearInput; + end; + done; +end +{$ELSE} + Uses WinCrt; + begin + Writeln('This program is not compilable for windows'); + end +{$ENDIF}. + + diff --git a/FILE_ID.DIZ b/FILE_ID.DIZ new file mode 100644 index 0000000..c8be1bb --- /dev/null +++ b/FILE_ID.DIZ @@ -0,0 +1,25 @@ +┌─┼──────────────────────────────┼─┐ +┼─┼ Эхо снов (DREAMS) ───────────┼─┼ +│ │ │ │ +│ │ - FLASH system programming │ │ +│ │ example │ │ +│ │ - featuring FX-API/2 engine │ │ +│ │ - limited version │ │ +│ │ - full script sources │ │ +│ │ - read_me.1st │ │ +│ │ - freeware │ │ +│ │ - native russian game │ │ +│ │ - more adventure than quest │ │ +│ │ - great for all who like │ │ +│ │ LEGEND ent. :)) │ │ +│ │ - bug reporting are always │ │ +│ │ welcome ! │ │ +│ │ - try to change script ! │ │ +│ │ - do your own game ! │ │ +│ │ - FLASH 2.0 will be if we │ │ +│ │ find producer ! │ │ +│ │ │ │ +│ │ wize@orc.ru │ │ +┼─┼ (C) 1995,97 WIZECORE ────────┼─┼ +└─┼──────────────────────────────┼─┘ + diff --git a/FX_CONS.PAS b/FX_CONS.PAS new file mode 100644 index 0000000..937cedd --- /dev/null +++ b/FX_CONS.PAS @@ -0,0 +1,71 @@ +Unit fx_cons; + +interface + + Uses TPStr; + + function Consoled: boolean; + procedure Console_out(text:string); + procedure Console_outtext(TextArr:PStringArr); + procedure Show_console; + +implementation + + uses flaction,tpcomms,parsing,fx_console,fx_init,fx_mouse; + + const Exit = 'stop'; + ConsoleX = 10; + ConsoleY = 10; + ConsoleW = 150; + ConsoleH = 80; + + var Console : PConsole; + +procedure Console_out; +begin + if Console<>Nil then Console^.Output(Text); +end; + +function Consoled; +begin + Consoled:=Console<>Nil; +end; + +procedure Console_Outtext; + var i:integer; +begin + if Consoled then + for i:=0 to TextArr^.Count-1 do Console_out(TextArr^.Get(i)); +end; + +procedure Show_console; + var s:string; + cmd:integer; +begin + if Console<>nil then Console^.output('Consol already displayed') + else begin + Hide_mouse; + New(Console,Init(ConsoleW,ConsoleH,LightFont,Screen)); + Console^.Show(ConsoleX,ConsoleY); + Show_mouse; + Console^.output('FLASH Language console.'); + Console^.output('Press "stop" to exit'); + repeat + s:=console^.input; + if (s='') or (s=' ') then continue; + if same(s,exit) then break; + cmd:=findcomm(Argument(S,0)); + s:=Tail(S,1); + if cmd<>-1 + then MakeCommand(Cmd,S) + else Console^.Output('Unknown command'); + until same(s,exit); + Hide_mouse; + Dispose(Console,Done); + Console:=Nil; + Show_mouse; + end; +end; + +begin +end. diff --git a/FX_CONSO.PAS b/FX_CONSO.PAS new file mode 100644 index 0000000..bffd229 --- /dev/null +++ b/FX_CONSO.PAS @@ -0,0 +1,135 @@ +Unit fx_console; + +interface + +uses fx_form,fx_fonts,fx_dev; + +type PConsole = ^TConsole; + TConsole = object(TGr_Object) + Line : string; + Wid,Hgt : Word; + constructor init(AWid,AHgt:Word; afont:pfont; adevice:pdevice); + destructor done; virtual; + function width:word; virtual; + function height:word; virtual; + procedure repaint; virtual; + + procedure output(s:string); + function input:string; + procedure cls; + end; + +implementation + + uses misc,data,fx_pens,core; + +procedure MoveArea(dev:pdevice; x,y,w,h:word;x1,y1:word); + var d:pdevice; +begin + new(d,init(w,h)); + dev^.partdevicecopy(0,0,x,y,w,h,d); + d^.fulldevicecopy(x1,y1,dev); + dispose(d,done); +end; + + procedure TConsole.cls; + begin + if viewed then repaint; + end; + function TConsole.input; + var ch:char; + procedure clearpos; + var x :integer; + c:pcolorpen; + begin + x:=Font^.lnWIDTH('*'); + new(c,init(cMENUGROUND)); + device^.map( startx + Font^.LnWidth(Line), + starty + Hgt - Font^.LnHeight , + startx + Font^.LnWidth(Line) + x, + starty + Hgt ,c ); + dispose(c,done); + end; + procedure backdel; + var ch:char; + x :integer; + c:pcolorpen; + begin + ch:=Line[Length(Line)]; + Line:=Copy(Line,1,Length(Line)-1); + x:=Font^.lnWIDTH(ch+'*'); + new(c,init(cMENUGROUND)); + device^.map( startx + Font^.LnWidth(Line), + starty + Hgt - Font^.LnHeight , + startx + Font^.LnWidth(Line) + x, + starty + Hgt ,c ); + Font^.Writelen( StartX+1, + StartY+Hgt-Font^.lnHeight+1, + Wid-2,Device,Line+'*'); + dispose(c,done); + end; + begin + if not viewed then ErrorMSG('Can`t input from console in INVISIBLE state !'); + output(''); + line:='>'; + Font^.Writelen(StartX+1, StartY+Hgt-Font^.lnHeight+1, Wid-2,Device,Line+'-'); + repeat + ch:=readkey; + if ch=#13 then begin + line:=copy(line,2,256); + input:=line; + line:=line+'*'; + clearpos; + exit; + end else if ch=#8 + then begin + if line<>'>' then backdel + end + else begin + if Font^.lnWidth(line+'*')>wid-6 then continue; + clearpos; + Line:=line + ch; + Font^.Writelen( StartX+1, + StartY+Hgt-Font^.lnHeight+1, + Wid-2,Device,Line+'*'); + end; + until ch=#13; + end; + procedure TConsole.output; + var c:pcolorpen; + begin + if not viewed then exit; + MoveArea( Device,StartX+1,StartY+Font^.lnHeight + 2, + Wid,Hgt-Font^.lnHeight - 1, + StartX+1,StartY+1); + new(c,init(cMENUGROUND)); + device^.map( StartX,StartY+Hgt-Font^.lnHeight, + StartX+Wid-1,StartY+Hgt,c); + dispose(c,done); + Font^.Writelen(StartX+1, StartY+Hgt-Font^.lnHeight+1, Wid-2,Device,s); + Line := S; + end; + procedure TConsole.repaint; + begin + end; + constructor TConsole.init; + begin + inherited init( make_form(butt_fr,new(pcolorpen,init(cMENUGROUND)),afont), + 3, adevice); + Wid:=AWid; + Hgt:=AHgt; + end; + destructor TConsole.Done; + begin + inherited done; + end; + function TConsole.width; + begin + width := inherited width + Wid + 2; + end; + function TConsole.Height; + begin + height := inherited height + Hgt + 2; + end; + +end. \ No newline at end of file diff --git a/FX_LOG.PAS b/FX_LOG.PAS new file mode 100644 index 0000000..eb86fc9 --- /dev/null +++ b/FX_LOG.PAS @@ -0,0 +1,50 @@ +Unit fx_log; + +interface + + function Consoled: boolean; + procedure Console_out(text:string); + procedure Show_console; + +implementation + + uses flaction,tpcomms,parsing,fx_console,fx_init; + + const Exit = 'exit'; + ConsoleX = 10; + ConsoleY = 10; + ConsoleW = 150; + ConsoleH = 80; + + var Console : PConsole; + +procedure Console_out; +begin + if Console<>Nil then Console^.Output(Text); +end; + +function Consoled; +begin + Consoled:=Console<>Nil; +end; + +procedure Show_console; + var s:string; + cmd:integer; +begin + New(Console,Init(ConsoleW,ConsoleH,LightFont,Screen)); + Console^.Show(ConsoleX,ConsoleY); + repeat + s:=console^.input; + cmd:=findcomm(Argument(S,0)); + s:=Tail(S,1); + if cmd<>-1 + then MakeCommand(Cmd,S) + else Console^.Output('Unknown command'); + until same(s,exit); + Dispose(Console,Done); + Console:=Nil; +end; + +begin +end. \ No newline at end of file diff --git a/INCLUDES/ACTIT.PAS b/INCLUDES/ACTIT.PAS new file mode 100644 index 0000000..1780a1c --- /dev/null +++ b/INCLUDES/ACTIT.PAS @@ -0,0 +1,184 @@ + +procedure act_default(obj:pclass); + var cm:pflashcomm; +begin + case obj^.class of + nTHING: begin + CurrentThing:=obj^.Name; + cm:=obj^.acts^.getname(cDefaultAct); + if cm<>nil + then cm^.run + else MessageWindow(PTHING(obj)^.text); + Atmo^.TimeLine^.ProcessEvents; + end; + nLOC : begin + cm:=obj^.acts^.getname(cDescribe); + if cm<>nil + then cm^.run + else MessageWindow(PLocation(obj)^.text); + Atmo^.TimeLine^.ProcessEvents; + end; + nHUMAN: begin + cm:=obj^.acts^.getname(cDOTALK); + if cm<>nil + then cm^.run + else MessageWindow(PHuman(obj)^.text); + Atmo^.TimeLine^.ProcessEvents; + end; + end; +end; + + +procedure add_orel(obj:pclass; var list:tlist); + var a:integer; + name:string[16]; +begin + for a:=0 to obj^.acts^.count-1 do + begin + name:=obj^.acts^.get(a)^.name; + if name[1]<>'#' + then if list.length=listsize + then ErrorMSG(Str2Pchar('Can`t add orel to list for '+obj^.name)) + else begin + list.listing[list.length].listname:=name; + list.listing[list.length].class:=orel; + inc(list.length); + end; + end; +end; + + +const + cEX_PREFIX = 'Exclude_'; + + +procedure add_grel(obj:pclass; var list:tlist); + var a:integer; + name:string[16]; + +function must_exclude(act:nstring):boolean; +begin + if (obj^.class=NThing) + then begin + if PThing(Obj)^.Params^.SearchRec(cEX_PREFIX+Act)<>nil + then must_exclude:=true else must_exclude:=false; + end else must_exclude:=false; +end; + +begin + for a:=0 to actlist^.count-1 do + begin + name:=actlist^.get(a)^.name; + if (name[1]<>'#') and (not must_exclude(name)) + then if list.length=listsize + then ErrorMSG(Str2Pchar('Can`t add grel '+name+' for unkown')) + else begin + list.listing[list.length].listname:=name; + list.listing[list.length].class:=grel; + inc(list.length); + end; + end; +end; + +procedure make_list(obj:pclass; var list:tlist); +begin + list.length:=0; + case obj^.class of + nTHING:begin + CurrentThing:=obj^.Name; + add_grel(obj,list); + add_orel(obj,list); + end; + nLOC :begin + add_orel(obj,list); + end; + nHUMAN:begin + add_orel(obj,list); + add_grel(obj,list); + end; + end; +end; + +function choose(butt:pbutton_line):integer; + var i:integer; + x,y:word; +begin + hide_mouse; + if butt^.viewed then butt^.hide; + if not butt^.viewed then begin + + if butt^.height+5+mouseposy>Screen^.height + then y:=Screen^.height-butt^.height-1 + else y:=mouseposy; + + if butt^.width+5+mouseposx>Screen^.Width + then x:=Screen^.Width-butt^.width-1 + else x:=mouseposx; + + butt^.show(x,y); + end; + show_mouse; + while true do begin + + if mousebuttons=02 then begin + while mousebuttons<>0 do; + choose:=-1; + exit; + end; + + if mousebuttons=01 + then begin + i:=butt^.pressed(mouseposx,mouseposy); + if i<>-1 then begin + press_snd.play; + choose:=i; + while mousebuttons<>0 do; + exit; + end else while mousebuttons<>0 do; + end; + end; +end; + +procedure act_list(obj:pclass); +var + list:plist; + butt:pbutton_line; + c:byte; + a,wasb,len,len1:integer; +begin + new(list); + make_list(obj,list^); + if list^.length=0 then begin + dispose(list); + exit; + end; + if list^.length<10 + then c:=list^.length + else c:=10; + + len:=LightFont^.lnWidth(obj^.playname); + for a:=0 to list^.length-1 do begin + len1:=LightFont^.lnWidth(list^.listing[a].listname); + if len1>len then len:=len1; + end; + + new(butt,init(c,len+15,obj^.playname)); + for a:=0 to list^.length-1 do butt^.add_butt(list^.listing[a].listname); + wasb:=butt^.buttons; + a:=choose(butt); + hide_mouse; + dispose(butt,done); + show_mouse; + if (a<>-1) and (a<>wasb) then + case list^.listing[a].class of + orel : begin + obj^.acts^.getname(list^.listing[a].listname)^.run; + Atmo^.TimeLine^.ProcessEvents; + end; + grel : begin + pact(actlist^.find(list^.listing[a].listname))^.run(obj^.name); + Atmo^.TimeLine^.ProcessEvents; + end; + end; + dispose(list); +end; diff --git a/INCLUDES/ACTTALK.PAS b/INCLUDES/ACTTALK.PAS new file mode 100644 index 0000000..caced8b --- /dev/null +++ b/INCLUDES/ACTTALK.PAS @@ -0,0 +1,50 @@ + var talkrec:ttalkrec; + + procedure new_talk(s:string); + begin + init_talkrec(s,talkrec); + end; + procedure addchoice_talk(s:string); + begin + addchoice_talkrec(s,talkrec); + end; + procedure addtext_talk(s:string); + begin + addtext_talkrec(s,talkrec); + end; + procedure addvar_talk(s:string); + begin + addvar_talkrec(s,talkrec); + end; + procedure topictext_talk(s:string); + begin + topic2text(s,talkrec); + end; + procedure topicchoice_talk(s:string); + begin + topic2choice(s,talkrec); + end; + procedure topicvar_talk(s:string); + begin + topic2var(s,talkrec); + end; + procedure do_talk(s:string); + begin + quered:=show_talk(talkrec,screen); + done_talkrec(talkrec); + end; + + procedure regist_talk; + begin + appendcomm('talkopen',new_talk); + + appendcomm('talktext',addtext_talk); + appendcomm('talkchoice',addchoice_talk); + appendcomm('talkvar',addvar_talk); + + appendcomm('talklibtext',topictext_talk); + appendcomm('talklibchoice',topicchoice_talk); + appendcomm('talklibvar',topicvar_talk); + + appendcomm('talkdo',do_talk); + end; diff --git a/INCLUDES/COLORMEN.PAS b/INCLUDES/COLORMEN.PAS new file mode 100644 index 0000000..03bd071 --- /dev/null +++ b/INCLUDES/COLORMEN.PAS @@ -0,0 +1,63 @@ + +procedure colormenu; + + procedure showcolor(x,y,x1,y1:word; colornum:byte); + var c,c0:pcolorpen; + begin + new(c,init(colornum)); + new(c0,init(0)); + screen^.rectangle(x,y,x1,y1,c0); + screen^.map(x+1,y+1,x1-1,y1-1,c); + lightfont^.writeln(x+1,y+1,screen,tostr(colornum)); + dispose(c,done); + dispose(c0,done); + end; + + const + cmenux=10; + cmenuy=10; + + var + menu:pbutton_line; + c:byte; + i:integer; +begin + hide_mouse; + clip; + show_mouse; + new(menu,init(4,60,'Color')); + menu^.add_butt('more_number'); + menu^.add_butt('less_number'); + menu^.add_butt('edit_number'); + menu^.add_butt('exit'); + hide_mouse; + menu^.show(cmenux,cmenuy); + show_mouse; + c:=0; + hide_mouse; + showcolor(100,10,130,40,c); + show_mouse; + while true do + if mousebuttons<>0 + then begin + i:=menu^.pressed(mouseposx,mouseposy); +{ while mousebuttons<>0 do;} + if i<>-1 + then begin + press_snd.play; + case i of + 0: {$R-,Q-} inc(c); + 1: {$R-,Q-} dec(c); + 2: c:=tobyte(Receive('Color?>')); + 3: break; + end; + end; + hide_mouse; + showcolor(100,10,130,40,c); + show_mouse; + end; + hide_mouse; + dispose(menu,done); + clipoff; + show_mouse; +end; diff --git a/INCLUDES/ICONBAR.PAS b/INCLUDES/ICONBAR.PAS new file mode 100644 index 0000000..02ecaba --- /dev/null +++ b/INCLUDES/ICONBAR.PAS @@ -0,0 +1,211 @@ +{$R-,Q-} +type + piconbar=^ticonbar; + ticonbar=object(tgr_object) + iconw :word; + iconh :word; + iconlen :word; + icons :integer; + icon:array[0..cMaxIcons] of PDevice; + moveup,movedn:pdevice; + current:word; + + upx,upy,dnx,dny:word; + picx,picy:word; + + constructor init(aiconw,aiconh,aiconlen:word); + function add_icon(devname:string):integer; + destructor done; virtual; + function width:word; virtual; + function height:word; virtual; + procedure redraw_arrows; + procedure redraw_icons(start:word); + procedure redraw_icon(num:word; x,y:word); + + procedure repaint; virtual; + function choose(x,y:word):integer; + function lazychoose(x,y:word):integer; + + { minus - up; plus - dn } + procedure scroll(val:integer); + end; + procedure ticonbar.scroll; + var start:word; + begin + if icons<=iconlen then exit; + if viewed then begin + if val+current<0 + then start:=0 + else if val+current+iconlen>=icons + then start:=icons-iconlen + else start:=val+current; + current:=start; + redraw_icons(current); + end; + end; + function ticonbar.lazychoose; + begin + if icons<=0 + then begin + lazychoose:=-1; + end else + + if viewed then begin + if belongs(x,startx+picx,startx+picx+iconw-1) and + belongs(y,starty+picy,starty+picy+(iconh+cICONSP)*iconlen-1-cICONSP) + then begin + y:=(y-starty-picy) div (iconh+cICONSP); + lazychoose:=y+current; + if y+current>icons-1 then lazychoose:=-1; + end else lazychoose:=-1; + end; + end; + function ticonbar.choose; + begin + if icons<=0 + then begin + choose:=-1; + end else + + if viewed then begin + if belongs(x,upx+startx,startx+upx+moveup^.width-1) and + belongs(y,upy+starty,starty+upy+moveup^.height-1) + then begin + PlaySound(sndClick); + scroll(-1); + choose:=-1; + end else + if belongs(x,startx+dnx,startx+dnx+movedn^.width-1) and + belongs(y,starty+dny,starty+dny+movedn^.height-1) + then begin + PlaySound(sndClick); + scroll(1); + choose:=-1; + end else + if belongs(x,startx+picx,startx+picx+iconw-1) and + belongs(y,starty+picy,starty+picy+(iconh+cICONSP)*iconlen-1-cICONSP) + then begin + y:=(y-starty-picy) div (iconh+cICONSP); + choose:=y+current; + if y+current>icons-1 then choose:=-1; + end else choose:=-1; + end; + end; + function ticonbar.width; + begin + if iconwiconw) or (icon[num]^.height>iconh) + then begin + new(p,init(cFILLCOL)); + device^.map(x,y,x+iconw-1,y+iconh-1,p); + dispose(p,done); + if icon[num]^.width>iconw + then w:=iconw + else begin + x:=x+abs(iconw-icon[num]^.height) div 2; + w:=icon[num]^.width; + end; + if icon[num]^.height>iconh + then h:=iconh + else begin + y:=y+abs(iconh-icon[num]^.height) div 2; + h:=icon[num]^.height; + end; + icon[num]^.partdevicecopy0(x,y,0,0,w,h,device) + end + else begin + new(p,init(cFILLCOL)); + device^.map(x,y,x+iconw-1,y+iconh-1,p); + dispose(p,done); + icon[num]^.fulldevicecopy0(x+ (iconw-icon[num]^.width ) div 2,y+ (iconh-icon[num]^.height) div 2,device ); + end; + end; + end; + procedure ticonbar.redraw_arrows; + var x,y:integer; + begin + if viewed then begin + moveup^.fulldevicecopy(upx+startx,upy+starty,device); + movedn^.fulldevicecopy(dnx+startx,dny+starty,device); + end; + end; + procedure ticonbar.redraw_icons; + var a,x,y,istart,iend:integer; + begin + x:=startx+picx; y:=starty+picy; + istart:=current; +{ if current+iconlen-1iconw + then upx:=0 + else upx:=(iconw-moveup^.width) div 2; + upy:=0; + dnx:=upx; + dny:=moveup^.height-1 + cICONSP + iconlen*(cICONSP+iconh)-1; + if moveup^.width-1 then + case butt of + 01: act_default(thinglist^.find(player^.things^.get(res))); + 02: act_list(thinglist^.find(player^.things^.get(res))); + end; +end; diff --git a/INCLUDES/TPDEFINE.INC b/INCLUDES/TPDEFINE.INC new file mode 100644 index 0000000..195d934 --- /dev/null +++ b/INCLUDES/TPDEFINE.INC @@ -0,0 +1,102 @@ +{*********************************************************} +{* TPDEFINE.INC 5.21 *} +{* Assorted conditional compilation directives *} +{* Copyright (c) TurboPower Software 1988, 1992. *} +{* Portions Copyright (c) Sunny Hill Software 1985, 1986 *} +{* and used under license to TurboPower Software *} +{* All rights reserved. *} +{*********************************************************} + +{This directive determines whether or not TPCRT is compiled in such a way as + to coexist peacefully with the standard Turbo Pascal CRT unit.} + +{$DEFINE UseCrt} + +{This directive enables mouse support in several of the units, as well as in + some of the demo programs} + +{$DEFINE UseMouse} + +{The following define controls whether items within a menu system can + be temporarily disabled and re-enabled, and whether menus can be shadowed. + Defining Tpro5Menu will break (in a small way) menu systems defined with + Turbo Professional 4.0. The extent of the problem is limited to the color + arrays defined for each menu system -- the new color array requires two + additional items.} + +{.$DEFINE Tpro5Menu} + +{If FourByteDates is defined, dates in TPDATE are stored as longints, giving a +range of 01/01/1600-12/31/3999. If it isn't defined, dates are stored as +words, giving a range of 01/01/1900-12/31/2078. WARNING! Between version 5.08 +and 5.09, we corrected a bug in TPDATE that affected date calculations when +FourByteDates was NOT defined. If you have been using word-sized dates with a +version of Turbo Professional prior to 5.09, please be sure to read the +discussion of this problem in the READ.ME file.} + +{$DEFINE FourByteDates} + +{Disable the following define if you never need to display directories (using + TPDIR) with file size, date and time. Doing so reduces the final application + size by up to 3200 bytes.} + +{$DEFINE AllowDateTime} + +{The following directive enables numeric (right-to-left) editor in TPENTRY} + +{$DEFINE IncludeNumeric} + +{The following directive enables multiple choice fields in TPENTRY} + +{$DEFINE IncludeChoice} + +{The following directive enables support for BCD reals in TPENTRY} + +{.$DEFINE UseBCD} + +{Deactivate the following define if the caller of TPSORT needs to perform + heap allocation or deallocation while the sort is in progress, that is, + within the user-defined procedures of the sort. For large sorts with + element size exceeding 4 bytes, FastDispose makes a significant difference + in the speed of heap deallocation when the sort is finished.} + +{$DEFINE FastDispose} + +{if the following directive is defined, TPTSR tries to thwart SideKick} + +{$DEFINE ThwartSideKick} + +{Deactivate the following define if exploding windows are not desired, + in order to save up to 2200 bytes of code space.} + +{.$DEFINE ExplodingWindows} + +{Deactivate the following define if shadowed windows are not desired, + in order to save up to 2000 bytes of code space.} + +{$DEFINE ShadowedWindows} + +{Activate the following define if scrollable data entry screens are desired} + +{$DEFINE TpEntryScrolls} + +{Activate the following define to allow unpickable items in TPPICK} + +{$DEFINE PickItemDisable} + +{Activate the following define to allow alternate orientations in TPPICK} + +{.$DEFINE EnablePickOrientations} + +{The following define controls how various TPRO units react to the heap + changes of TP6 and later. There's no need for you to modify it.} + + {$IFDEF Ver60} + {$DEFINE Heap6} + {$ENDIF} + + {$IFDEF Ver70} + {$DEFINE Heap6} + {$I-,P-,T-,Q-} + {$ENDIF} + \ No newline at end of file diff --git a/INCLUDES/VARS.PAS b/INCLUDES/VARS.PAS new file mode 100644 index 0000000..9f8a7a8 --- /dev/null +++ b/INCLUDES/VARS.PAS @@ -0,0 +1,41 @@ +const + cGLOBVARPRE='$'; + +var GlobVar:PParamColl; + +procedure GlobVarReplace(Var CMD:String); + var i:integer; +begin + for i:=0 to GlobVar^.count-1 do + if Pos(cGLOBVARPRE+GlobVar^.Get(i)^.Param,CMD)<>0 + then fx_strop.replace( cGLOBVARPRE+GlobVar^.Get(i)^.Param, + GlobVar^.Get(i)^.Value,CMD ); +end; + +procedure done_globvars; +begin + dispose(GlobVar,Done); +end; + +procedure init_globvars; +begin + New(GlobVar,init); + add_exit_proc(@done_globvars); +end; + +procedure control_var(s:string); + var + param:string; + value:string; + par:pparam; +begin + param:=Argument(s,0); + Value:=Copy(s,Pos(Param,s)+Length(Param)+1,255); + if Same(Param,'QUERY') + then Quered:=value; + par:=GlobVar^.SearchRec(Param); + if par<>nil + then par^.Value:=Value + else GlobVar^.Param(Param,Value); +end; + diff --git a/INCLUDES/VIEW.PAS b/INCLUDES/VIEW.PAS new file mode 100644 index 0000000..cd02261 --- /dev/null +++ b/INCLUDES/VIEW.PAS @@ -0,0 +1,17 @@ +{ view definitions } +const + cView :viewrec=( + x: 0; y: 0; w:259; h:174 ); + + cStatus :viewrec=( + x: 0; y:160; w:260; h:10 ); + + cMenu :viewrec=( + x:260; y: 0; w: 60; h:200 ); + + cDreams :viewrec=( + x:265; y: 3; w: 50; h: 38 ); + cWizecore :viewrec=( + x:260; y:183; w: 60; h: 14 ); +{ end of view defs } + diff --git a/INCLUDES/XMSSTRM.INC b/INCLUDES/XMSSTRM.INC new file mode 100644 index 0000000..6217077 --- /dev/null +++ b/INCLUDES/XMSSTRM.INC @@ -0,0 +1,383 @@ +{ This include file is a slightly modified version of XMSSTRM.PAS, by Stefan + Boether, included here with his kind permission. -djm } + + (*****************************************************************************) + (* *) + (* Filename : XMSSTRM.INC *) + (* Autor : Stefan Boether / Compuserve Id : 100023,275 *) + (* System : TURBO 6.00 / MS-DOS 3.2 / Netzwerk *) + (* Aenderung : *) + (* wann was wer *) + (*---------------------------------------------------------------------------*) + (* 22.03.92 Error fixed with NewBlock and UsedBlocks Stefc *) + (* 28.04.92 Size field added, BlockSize made constant DJM *) + (* 15.10.92 Off-by-one bug fixed in Seek method DJM *) + (*****************************************************************************) + (* Beschreibung: Object for an Stream in XMS-Memory *) + (*****************************************************************************) + {Header-End} + +{!!!!!!!!!!!!!!! + program Test; + + uses objects, XmsStrm; + + var T : TXmsStream; + P : PString; + +begin + writeln( xms_MaxAvail, ' ', xms_MemAvail ); + T.Init( 20, 20 ); + T.WriteStr( NewStr( 'Hello' )); + T.WriteStr( NewStr( 'World' )); + T.Seek( 0 ); + P := T.ReadStr; + writeln( P^ ); + P := T.ReadStr; + writeln( P^ ); + T.Done; +end. + +!!!!!!!!!!!!!!!!} + +var xms_IOsts : Byte; + xms_Addr : Pointer; + +const + xms_Initialized : Boolean = False; + { This allows us to avoid a unit initialization section } + + xms_BlockSize = 1024; + + { - Some Xms - Procedures that I need ! -} + + (* /////////////////////////////////////////////////////////////////////// *) + + procedure MoveMem(ToAddress : Pointer; ToHandle : Word; + FromAddress : Pointer; FromHandle : Word; + Size : LongInt); + begin + asm + mov byte ptr xms_IOsts,0 + mov ah,$0B + lea si,Size + push ds + pop es + push ss + pop ds + call es:[xms_Addr] + push es + pop ds + or ax,ax + jnz @@1 + mov byte ptr xms_IOsts,bl +@@1: + end; + end; + + (* /////////////////////////////////////////////////////////////////////// *) + + function GetByte(Handle : Word; FromAddress : LongInt) : Byte; + var TempBuf : array[0..1] of Byte; + begin + MoveMem(@TempBuf, 0, Pointer(FromAddress and $FFFFFFFE), Handle, 2); + GetByte := TempBuf[FromAddress and $00000001]; + end; + + (* /////////////////////////////////////////////////////////////////////// *) + + procedure SetByte(Handle : Word; ToAddress : LongInt; Value : Byte); + var TempBuf : array[0..1] of Byte; + begin + MoveMem(@TempBuf, 0, Pointer(ToAddress and $FFFFFFFE), Handle, 2); + TempBuf[ToAddress and $00000001] := Value; + MoveMem(Pointer(ToAddress and $FFFFFFFE), Handle, @TempBuf, 0, 2); + end; + + (* /////////////////////////////////////////////////////////////////////// *) + + procedure xms_Init; + begin + if not xms_Initialized then + begin + xms_IOsts := 0; + xms_Addr := nil; + asm + mov ax,$4300 + int $2F + cmp al,$80 + jne @@1 + mov ax,$4310 + int $2F + mov word ptr xms_Addr,bx + mov word ptr xms_Addr+2,es + jmp @@2 +@@1: + mov byte ptr xms_IOsts,$80 +@@2: + end; + if xms_IOsts = 0 then + xms_Initialized := True; + end; + end; + + (* /////////////////////////////////////////////////////////////////////// *) + + function xms_GetMem(KB : Word) : Word; Assembler; + asm + mov xms_IOsts,0 + mov ah,$09 + mov dx,word ptr KB + call [xms_Addr] + or ax,ax + jz @@1 + mov ax,dx + jmp @@2 +@@1: + mov byte ptr xms_IOsts,bl +@@2: + end; + + (* /////////////////////////////////////////////////////////////////////// *) + + procedure xms_FreeMem(Handle : Word); + begin + asm + mov xms_IOsts,0 + mov ah,$0A + mov dx,word ptr Handle + call [xms_Addr] + or ax,ax + jnz @@1 + mov byte ptr xms_IOsts,bl +@@1: + end; + end; + + (* /////////////////////////////////////////////////////////////////////// *) + + procedure xms_ResizeMem(Size, Handle : Word); + begin + asm + mov ah,$0F + mov bx,word ptr Size + mov dx,word ptr Handle + call [xms_Addr] + or ax,ax + jnz @@1 + mov byte ptr xms_IOsts,bl +@@1: + end; + end; + + (* /////////////////////////////////////////////////////////////////////// *) + + procedure xms_MoveFrom(Size, Handle : Word; FromAddress : LongInt; + ToAddress : Pointer); + type ByteArr = array[0..MaxInt] of Byte; + BytePtr = ^ByteArr; + begin + if Size = 0 then Exit; + if Odd(FromAddress) then begin + BytePtr(ToAddress)^[0] := GetByte(Handle, FromAddress); + if xms_IOsts <> 0 then Exit; + Dec(Size); + Inc(FromAddress); + Inc(LongInt(ToAddress)); + end; + MoveMem(ToAddress, 0, Pointer(FromAddress), Handle, Size and $FFFE); + if xms_IOsts <> 0 then Exit; + if Odd(Size) + then BytePtr(ToAddress)^[Size-1] := GetByte(Handle, FromAddress+Size-1); + if xms_IOsts <> 0 then Exit; + end; + + (* /////////////////////////////////////////////////////////////////////// *) + + procedure xms_MoveTo(Size, Handle : Word; FromAddress : Pointer; + ToAddress : LongInt); + type ByteArr = array[0..MaxInt] of Byte; + BytePtr = ^ByteArr; + begin + if Size = 0 then Exit; + if Odd(ToAddress) then begin + SetByte(Handle, ToAddress, BytePtr(FromAddress)^[0]); + if xms_IOsts <> 0 then Exit; + Dec(Size); + Inc(LongInt(FromAddress)); + Inc(ToAddress); + end; + MoveMem(Pointer(ToAddress), Handle, FromAddress, 0, Size and $FFFE); + if xms_IOsts <> 0 then Exit; + if Odd(Size) + then SetByte(Handle, ToAddress+Size-1, BytePtr(FromAddress)^[Size-1]); + if xms_IOsts <> 0 then Exit; + end; + + (* /////////////////////////////////////////////////////////////////////// *) + + constructor TXMSStream.Init(MinSize, MaxSize : longint); + var + MinBlocks,MaxBlocks : word; + begin + TStream.Init; + xms_Init; + BlocksUsed := 0; + Size := 0; + Position := 0; + Handle := 0; + MaxSize := MinLong(MaxSize,xms_Maxavail); + MaxBlocks := (MaxSize + xms_Blocksize -1) div xms_Blocksize; + MinBlocks := (MinSize + xms_Blocksize -1) div xms_Blocksize; + if MinBlocks < 1 then + MinBlocks := 1; + if MaxBlocks < MinBlocks then + MaxBlocks := MinBlocks; + if xms_IOsts <> $00 then + Error(stInitError, xms_IOsts) + else + begin + Handle := xms_GetMem(MaxBlocks); + if xms_IOsts <> $00 then + Error(stInitError, xms_IOsts) + else + begin + xms_ResizeMem(MinBlocks,Handle); + BlocksUsed := MinBlocks; + if xms_IOsts <> $00 then + Error(stInitError, xms_IOsts); + end; + end; + end; + + function TXMSStream.GetPos : LongInt; + begin + GetPos := Position; + end; + + function TXMSStream.GetSize : LongInt; + begin + GetSize := Size; + end; + + procedure TXMSStream.Read(var Buf; Count : Word); + begin + if Status = stOK then + if Position+Count > Size then + Error(stReaderror, 0) + else + begin + xms_MoveFrom(Count, Handle, Position, @Buf); + if xms_IOsts <> 0 then + Error(stReaderror, xms_IOsts) + else + Inc(Position, Count); + end; + end; + + procedure TXMSStream.Seek(Pos : LongInt); + begin + if Status = stOK then + if Pos > Size then { 1.4: bug fix } + Error(stReaderror, Pos) + else + Position := Pos; + end; + + procedure TXMSStream.Truncate; + begin + if Status = stOK then + begin + Size := Position; + while (BlocksUsed > (Size div xms_BlockSize+1)) do FreeBlock; + end; + end; + + procedure TXMSStream.Write(var Buf; Count : Word); + begin + while (Status = stOK) + and (Position+Count > LongMul(xms_BlockSize, BlocksUsed)) do + NewBlock; + if Status = stOK then + begin + xms_MoveTo(Count, Handle, @Buf, Position); + if xms_IOsts <> 0 then + Error(stWriteError, xms_IOsts) + else + Inc(Position, Count); + if Position > Size then + Size := Position; + end; + end; + + procedure TXMSStream.NewBlock; + begin + xms_ResizeMem(Succ(BlocksUsed), Handle); + if xms_IOsts <> 0 then + Error(stWriteError, xms_IOsts) + else + Inc(BlocksUsed); + end; + + procedure TXMSStream.FreeBlock; + begin + Dec(BlocksUsed); + xms_ResizeMem(BlocksUsed, Handle); + end; + + function xms_MaxAvail : Longint; + begin + xms_Init; + if xms_IOsts = 0 then + asm + xor bx, bx { for better error checking, since qemm +6.0 leaves bl unchanged on success } + mov ah,$08 + call [xms_Addr] + or bl, bl { extended error checking by MM 22.02.93 } + jz @OK + mov byte ptr xms_IOsts,bl + xor ax,ax +@OK: + mov dx,xms_Blocksize + mul dx + mov word ptr @result,ax + mov word ptr @result[2],dx + end + else + xms_MaxAvail := 0; + end; + + (* /////////////////////////////////////////////////////////////////////// *) + + function xms_MemAvail : Longint; + begin + xms_Init; + if xms_IOsts = 0 then + asm + xor bx, bx { for better error checking, since qemm +6.0 leaves bl unchanged on success } + mov ah,$08 + call [xms_Addr] + or bl, bl { extended error checking by MM 22.02.93 } + jz @OK + mov byte ptr xms_IOsts,bl + xor dx,dx +@OK: + mov ax,dx + mov dx,xms_blocksize + mul dx + mov word ptr @result,ax + mov word ptr @result[2],dx + end + else + xms_MemAvail := 0; + end; + + destructor TXMSStream.Done; + begin +{ Seek(0); + Truncate; } + if xms_Initialized and (BlocksUsed > 0) then + xms_FreeMem(Handle); + end; diff --git a/MAKEP.BAT b/MAKEP.BAT new file mode 100644 index 0000000..e2afb25 --- /dev/null +++ b/MAKEP.BAT @@ -0,0 +1,3 @@ +@echo off +bpc dreams.pas -cp -m +copy compiled\dreams.exe drdpmi.exe >nul \ No newline at end of file diff --git a/MAKER.BAT b/MAKER.BAT new file mode 100644 index 0000000..f56d7ef --- /dev/null +++ b/MAKER.BAT @@ -0,0 +1,3 @@ +@echo off +bpc dreams.pas -cd -m +copy compiled\dreams.exe drreal.exe >nul \ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 0000000..790cc58 --- /dev/null +++ b/README.md @@ -0,0 +1,18 @@ +# Echo of Dreams + +This is source code for game "Echo of dreams" +written in 1997. + +Video (in russian) about it: https://www.youtube.com/watch?v=zAwNgZmC9bE + +## Information about game + + * Borland Pascal 7.0 + * Uses 320x200 VGA mode + * FLASH SYSTEM - scripting engine for writing games + +## Files included + + * READ_ME.1ST Introduction and description in Russian + * READ_ME.2ST Additional information in Russian + * FILE_ID.DIZ BBS style file description in Russian \ No newline at end of file diff --git a/READ_ME.1ST b/READ_ME.1ST new file mode 100644 index 0000000..d0004dd --- /dev/null +++ b/READ_ME.1ST @@ -0,0 +1,49 @@ + + Пеpед Вами демонстpационная игpа + ЭХО СHОВ ( Dreams ) + + В данном докyменте описаны основные особенности этого пpодyкта. + + - Игpа была написана двyмя автоpами : + Гайнyтдиновым Рyсланом и Моченевым Дмитpием. + + - Тpебования к компьютеpy : + Общие : + - Min CPU 80386 & ?? FPU + - Мышь + - Базовой Памяти ~550 Kb ; аккypатнее !!! + - Памяти XMS 1 Mb + - Hа HDD 1 Mb + + - Гpафическая система основана на оpигинальном объектно-оpиентиpованном + engine, FX-API/2. + + - Данная веpсия (Real mode) не обладает следyющими возможностями : + - Использование DLL со своими собственными пpоцедypами + - Пакет написания DLL использyя FX-API/2 + - Пpавильной pаботы с SB + - Отсyтствием огpаничений на pазмеp скpипта и вообще всей системы. + + - Файл сценаpия специально не был закодиpован для того, чтобы Вы смогли + yвидеть/оценить/поэкспеpементиpовать с ним. + Он называется \SCRIPT\SCRIPT.DAT + Исходники Файла сценаpия находятся в диpектоpии \SCRIPT\SOURCE\ + + - Сценаpий написан на специально pазpаботанным нами языке + FLASH (Frame Language of Adventure System Host) + + - Игpа ни в коей меpе не носит коммеpческого хаpактеpа, поэтомy свободна + для HЕ коммеpческого pаспpостpанения (желательно, с оповещением автоpов). + + - Автоpы бyдyт благодаpны за любые отзывы/жалобы/пожелания. + + - Очень пpиветствyются любые пpедложения о сотpyдничестве. + + - Адpеса для контактов : + + Общий технический ....... 2:5020/1091.0@fidonet + Гpафический энджайн ..... 2:5020/549.13@fidonet + Сценаpный энджайн ....... 2:5020/549.16@fidonet + + E-Mail .................. wize@orc.ru + diff --git a/READ_ME.2ND b/READ_ME.2ND new file mode 100644 index 0000000..10f8b0a --- /dev/null +++ b/READ_ME.2ND @@ -0,0 +1,31 @@ + + Дополнительная инфоpмация + +- попpобyйте запyстить dreams.exe /? +- попpобyйте нажать [SPACE] пpи загpyзке +- если вылетает или виснет по RunTime Error ??? at ????:???? попpобyте : + - F5 пpи загpyзке DOS + - Win`95 || OS/2 + - подеpгать ключи + - выключить sound + - dreams.exe -i -l + - dreams.exe -d -c +- если все еще виснет и вы не меняли скpипт и т.д., пожалyйста + запишите подpобно конфигypацию компьютеpа и вышлите + 2:5020/549.13 || wize@orc.ru. Скpиншоты глюка или ??? в Runtime error + очень и очень желательны. +- бyдте оккypатны - не запyскаейте игpy если память меньше 550 кил. +- акypатнее с pазмеpом сценаpия - не делайте его больше ~150 кил. +- сценаpий - это пpосто пpимеp pаботы и эффективности FLASH, только и всего. +- все каpтинки - СОДРАHЫ из дpyгих игp, пpосим пpощения, пpосто y нас + нет хyдожника. Пpедложения пpинимаются. Возмyщения о плохой гpафике не + pассматpиваются. +- тем кто хочет pазобpаться в FLASH - пишите пpишлем доки, + исходники pесypсов и т.д. +- всем комy интеpесно, пишите обстоятельно. +- хакеpов пpошy не беспокоиться - все и так в откpытом виде. +- комy очень интеpесно могy пpислать applets.dll библиотекy, для + написания собственных дополнительных пpоцедyp. +- попpобyйте OS/2 + + вечно ваш, Рyслан AKA Jango diff --git a/UNITS/DOSFUNCT.PAS b/UNITS/DOSFUNCT.PAS new file mode 100644 index 0000000..48b5bc8 --- /dev/null +++ b/UNITS/DOSFUNCT.PAS @@ -0,0 +1,917 @@ +UNIT DOSFunctions; + +INTERFACE + +TYPE + PDOSFindRecord = ^TDOSFindRecord; + TDOSFindRecord = RECORD + Filler: ARRAY[1..21] OF BYTE; + Attribute: BYTE; + Time: LONGINT; + Size: LONGINT; + NameZ: ARRAY[0..12] OF CHAR; + END; + +TYPE + PDOSFileHandle = ^TDOSFileHandle; + TDOSFileHandle = RECORD + Number: WORD; + END; + +TYPE + PDOSMemoryHandle = ^TDOSMemoryHandle; + TDOSMemoryHandle = RECORD + Offs: WORD; + Segment: WORD; + END; + +CONST + DOSFileAccessRead = 0; + DOSFileAccessWrite = 1; + DOSFileAccessReadWrite = 2; + +CONST + DOSFileAttrReadOnly = $01; + DOSFileAttrHidden = $02; + DOSFileAttrSystem = $04; + DOSFileAttrVolumeLabel = $08; + DOSFileAttrDirectory = $10; + DOSFileAttrArchive = $20; + +FUNCTION DOSResult: WORD; +FUNCTION DOSInDOSFlagGet: BYTE; +PROCEDURE DOSTimeGet(VAR Hour,Minute,Second,Second100: BYTE); +PROCEDURE DOSTimeSet(Hour,Minute,Second,Second100: BYTE); +PROCEDURE DOSDateGet(VAR Year: WORD; VAR Month,Day,DayOfWeek: BYTE); +PROCEDURE DOSDateSet(Year: WORD; Month,Day: BYTE); +PROCEDURE DOSInterruptVectorSet(InterruptNumber: BYTE; InterruptHandler: POINTER); +FUNCTION DOSInterruptVectorGet(InterruptNumber: BYTE): POINTER; +PROCEDURE DOSFindFirst(VAR DOSFindRecord: TDOSFindRecord; FileName: STRING; Attributes: WORD); +PROCEDURE DOSFindNext(VAR DOSFindRecord: TDOSFindRecord); +PROCEDURE DOSFileTemporaryCreate(VAR UserFileHandle: TDOSFileHandle; VAR FileName: STRING); +PROCEDURE DOSFileCreate(VAR UserFileHandle: TDOSFileHandle; FileName: STRING); +PROCEDURE DOSFileOpen(VAR UserFileHandle: TDOSFileHandle; FileName: STRING; AccessType: BYTE); +PROCEDURE DOSFileClose(VAR UserFileHandle: TDOSFileHandle); +PROCEDURE DOSFileRead(VAR UserFileHandle: TDOSFileHandle; VAR ReadBuffer; ReadCount: WORD; VAR ActuallyRead: WORD); +PROCEDURE DOSFileWrite(VAR UserFileHandle: TDOSFileHandle; VAR WriteBuffer; WriteCount: WORD; VAR ActuallyWritten: WORD); +PROCEDURE DOSFilePositionSet(VAR UserFileHandle: TDOSFileHandle; NewLocation: LONGINT); +FUNCTION DOSFilePositionGet(VAR UserFileHandle: TDOSFileHandle): LONGINT; +PROCEDURE DOSFileTruncate(VAR UserFileHandle: TDOSFileHandle); +FUNCTION DOSFileSizeGet(VAR UserFileHandle: TDOSFileHandle): LONGINT; +FUNCTION DOSFileEnd(VAR UserFileHandle: TDOSFileHandle): BOOLEAN; +PROCEDURE DOSFileDelete(FileName: STRING); +PROCEDURE DOSFileRename(FileName, NewFileName: STRING); +PROCEDURE DOSDiskCurrentSet(DiskDrive: BYTE); +FUNCTION DOSDiskCurrentGet: BYTE; +FUNCTION DOSDiskValidCount: BYTE; +FUNCTION DOSDiskSpaceFree(DiskDrive: BYTE): LONGINT; +FUNCTION DOSDiskSpaceTotal(DiskDrive: BYTE): LONGINT; +PROCEDURE DOSMemoryAllocate(VAR DOSMemoryHandle: TDOSMemoryHandle; Size: WORD); +PROCEDURE DOSMemoryDeallocate(VAR DOSMemoryHandle: TDOSMemoryHandle); +FUNCTION DOSMemoryAvail: WORD; + +IMPLEMENTATION + +VAR + LastError: WORD; + InDOSFlagPtr: POINTER; + +FUNCTION DOSResult: WORD; +ASSEMBLER; +ASM + MOV AX,[LastError] +END; + +PROCEDURE DOSTimeGet(VAR Hour,Minute,Second,Second100: BYTE); +ASSEMBLER; +ASM + MOV AH,2CH + INT 21H + + LES DI,[Hour] + MOV [ES:DI],CH + LES DI,[Minute] + MOV [ES:DI],CL + LES DI,[Second] + MOV [ES:DI],DH + LES DI,[Second100] + MOV [ES:DI],DL + + MOV [LastError],0H +END; + +PROCEDURE DOSTimeSet(Hour,Minute,Second,Second100: BYTE); +ASSEMBLER; +ASM + MOV AH,2DH + MOV CH,[Hour] + MOV CL,[Minute] + MOV DH,[Second] + MOV DL,[Second100] + INT 21H + + MOV [BYTE PTR LastError],AL + MOV [BYTE PTR LastError+1],0H +END; + +PROCEDURE DOSInterruptVectorSet(InterruptNumber: BYTE; InterruptHandler: POINTER); +ASSEMBLER; +ASM + MOV BX,DS + + MOV AH,25H + MOV AL,[InterruptNumber] + LDS DX,[InterruptHandler] + INT 21H + + MOV DS,BX + + MOV [LastError],0H +END; + +FUNCTION DOSInterruptVectorGet(InterruptNumber: BYTE): POINTER; +ASSEMBLER; +ASM + MOV AH,35H + MOV AL,[InterruptNumber] + INT 21H + + MOV AX,BX + MOV DX,ES + + MOV [LastError],0H +END; + +FUNCTION DOSInDOSFlagGet: BYTE; +ASSEMBLER; +ASM + LES DI,[InDOSFlagPtr] + MOV AL,[ES:DI] + + MOV [LastError],0H +END; + +PROCEDURE DOSFindFirst(VAR DOSFindRecord: TDOSFindRecord; FileName: STRING; Attributes: WORD); +ASSEMBLER; +VAR + PathBuffer: ARRAY[0..78] OF CHAR; +ASM + PUSH DS + MOV [LastError],0H + + MOV AH,1AH + LDS DX,[DOSFindRecord] + INT 21H + + CLD + + MOV AX,[WORD PTR FileName+2] + MOV DS,AX + MOV SI,[WORD PTR FileName] + LEA DI,PathBuffer + MOV DX,DI + MOV BX,SS + MOV ES,BX + MOV CL,[DS:SI] + XOR CH,CH + INC SI + CMP CL,79 + JBE @@MoveThem + + MOV CL,79 + +@@MoveThem: + SHR CX,1 + JNC @@DoWords + + MOVSB + +@@DoWords: + REP MOVSW + + MOV [BYTE PTR ES:DI],0H + + MOV AX,ES + MOV DS,AX + MOV AH,4EH + MOV CX,[Attributes] + INT 21H + POP DS + JNC @@Done + + MOV [LastError],AX + +@@Done: +END; + +PROCEDURE DOSFindNext(VAR DOSFindRecord: TDOSFindRecord); +ASSEMBLER; +ASM + MOV [LastError],0H + + MOV BX,DS + MOV AH,1AH + LDS DX,[DOSFindRecord] + INT 21H + MOV DS,BX + + MOV AH,4FH + INT 21H + JNC @@Done + + MOV [LastError],AX + +@@Done: +END; + +PROCEDURE DOSDateGet(VAR Year: WORD; VAR Month,Day,DayOfWeek: BYTE); +ASSEMBLER; +ASM + MOV AH,2AH + INT 21H + + LES DI,[Year] + MOV [ES:DI],CX + LES DI,[Month] + MOV [ES:DI],DH + LES DI,[Day] + MOV [ES:DI],DL + LES DI,[DayOfWeek] + MOV [ES:DI],AL + + MOV [LastError],0H +END; + +PROCEDURE DOSDateSet(Year: WORD; Month,Day: BYTE); +ASSEMBLER; +ASM + MOV CX,[Year] + MOV DH,[Month] + MOV DL,[Day] + MOV AH,2BH + INT 21H + + MOV [BYTE PTR LastError],AL + MOV [BYTE PTR LastError+1],0H +END; + +PROCEDURE DOSFileCreate(VAR UserFileHandle: TDOSFileHandle; FileName: STRING); +ASSEMBLER; +VAR + PathBuffer: ARRAY[0..78] OF CHAR; +ASM + PUSH DS + + CLD + + MOV AX,[WORD PTR FileName+2] + MOV SI,[WORD PTR FileName] + LEA DI,PathBuffer + MOV DX,DI + MOV DS,AX + MOV BX,SS + MOV ES,BX + + LODSB + XOR AH,AH + MOV CX,AX + CMP CL,79 + JBE @@MoveThem + + MOV CL,79 + +@@MoveThem: + SHR CX,1 + JNC @@DoWords + + MOVSB + +@@DoWords: + REP MOVSW + + MOV [BYTE PTR ES:DI],0H + + MOV AX,ES + MOV DS,AX + MOV AH,3CH + XOR CX,CX + INT 21H + POP DS + JC @@Error + + LES DI,[UserFileHandle] + MOV [TDOSFileHandle(ES:DI).Number],AX + MOV [LastError],0H + JMP @@Done + +@@Error: + MOV [LastError],AX + +@@Done: +END; + +PROCEDURE DOSFileTemporaryCreate(VAR UserFileHandle: TDOSFileHandle; VAR FileName: STRING); +ASSEMBLER; +ASM + PUSH DS + + LDS DX,[FileName] + INC DX + MOV DI,DX + MOV [BYTE PTR DS:DI],'\' + MOV [BYTE PTR DS:DI+1],0H + MOV AH,5AH + XOR CX,CX + INT 21H + POP DS + JC @@Error + + MOV BX,AX + MOV AX,[WORD PTR FileName+2] + MOV ES,AX + XOR AL,AL + MOV CX,79 + REPNE SCASB + MOV AX,78 + SUB AX,CX + MOV DI,DX + MOV [BYTE PTR ES:DI-1],AL + + LES DI,[UserFileHandle] + MOV [TDOSFileHandle(ES:DI).Number],BX + MOV [LastError],0H + JMP @@Done + +@@Error: + MOV [LastError],AX + +@@Done: +END; + +PROCEDURE DOSFileOpen(VAR UserFileHandle: TDOSFileHandle; FileName: STRING; AccessType: BYTE); +ASSEMBLER; +VAR + PathBuffer: ARRAY[0..78] OF CHAR; +ASM + PUSH DS + + CLD + + MOV AX,[WORD PTR FileName+2] + MOV SI,[WORD PTR FileName] + LEA DI,PathBuffer + MOV DX,DI + MOV DS,AX + MOV BX,SS + MOV ES,BX + + LODSB + XOR AH,AH + MOV CX,AX + CMP CL,79 + JBE @@MoveThem + + MOV CL,79 + +@@MoveThem: + SHR CX,1 + JNC @@DoWords + + MOVSB + +@@DoWords: + REP MOVSW + + MOV [BYTE PTR ES:DI],0H + + MOV AX,ES + MOV DS,AX + MOV AH,3DH + MOV AL,[AccessType] + INT 21H + POP DS + JC @@Error + + LES DI,[UserFileHandle] + MOV [TDOSFileHandle(ES:DI).Number],AX + MOV [LastError],0H + JMP @@Done + +@@Error: + MOV [LastError],AX + +@@Done: +END; + +PROCEDURE DOSFileClose(VAR UserFileHandle: TDOSFileHandle); +ASSEMBLER; +ASM + MOV AH,3EH + LES DI,[UserFileHandle] + MOV BX,[TDOSFileHandle(ES:DI).Number] + INT 21H + JC @@Error + + MOV [LastError],0H + JMP @@Done + +@@Error: + MOV [LastError],AX + +@@Done: +END; + +PROCEDURE DOSFileRead(VAR UserFileHandle: TDOSFileHandle; VAR ReadBuffer; ReadCount: WORD; VAR ActuallyRead: WORD); +ASSEMBLER; +ASM + PUSH DS + + MOV AH,3FH + LES DI,[UserFileHandle] + MOV BX,[TDOSFileHandle(ES:DI).Number] + MOV CX,[ReadCount] + LDS DX,[ReadBuffer] + INT 21H + POP DS + JC @@Error + + LES DI,[ActuallyRead] + MOV [ES:DI],AX + MOV [LastError],0H + JMP @@Done + +@@Error: + MOV [LastError],AX + +@@Done: +END; + +PROCEDURE DOSFileWrite(VAR UserFileHandle: TDOSFileHandle; VAR WriteBuffer; WriteCount: WORD; VAR ActuallyWritten: WORD); +ASSEMBLER; +ASM + PUSH DS + + MOV CX,[WriteCount] + JCXZ @@ZeroWrite + + MOV AH,40H + LES DI,[UserFileHandle] + MOV BX,[TDOSFileHandle(ES:DI).Number] + LDS DX,[WriteBuffer] + INT 21H + POP DS + JC @@Error + + LES DI,[ActuallyWritten] + MOV [ES:DI],AX + MOV [LastError],0H + JMP @@Done + +@@ZeroWrite: + LES DI,[ActuallyWritten] + MOV [WORD PTR ES:DI],CX + MOV [LastError],CX + JMP @@Done + +@@Error: + MOV [LastError],AX + +@@Done: +END; + +PROCEDURE DOSFilePositionSet(VAR UserFileHandle: TDOSFileHandle; NewLocation: LONGINT); +ASSEMBLER; +ASM + MOV AX,4200H + LES DI,[UserFileHandle] + MOV BX,[TDOSFileHandle(ES:DI).Number] + MOV DX,[WORD PTR NewLocation] + MOV CX,[WORD PTR NewLocation+2] + INT 21H + JC @@Error + + MOV [LastError],0H + JMP @@Done + +@@Error: + MOV [LastError],AX + +@@Done: +END; + +FUNCTION DOSFilePositionGet(VAR UserFileHandle: TDOSFileHandle): LONGINT; +ASSEMBLER; +ASM + MOV AX,4201H + LES DI,[UserFileHandle] + MOV BX,[TDOSFileHandle(ES:DI).Number] + XOR DX,DX + XOR CX,CX + INT 21H + JC @@Error + + MOV [LastError],0H + JMP @@Done + +@@Error: + MOV [LastError],AX + +@@Done: +END; + +PROCEDURE DOSFileTruncate(VAR UserFileHandle: TDOSFileHandle); +ASSEMBLER; +ASM + MOV AH,40H + XOR CX,CX + LES DI,[UserFileHandle] + MOV BX,[TDOSFileHandle(ES:DI).Number] + INT 21H + JC @@Error + + MOV [LastError],0H + JMP @@Done + +@@Error: + MOV [LastError],AX + +@@Done: +END; + +FUNCTION DOSFileSizeGet(VAR UserFileHandle: TDOSFileHandle): LONGINT; +ASSEMBLER; +ASM + MOV AX,4201H + LES DI,[UserFileHandle] + MOV BX,[TDOSFileHandle(ES:DI).Number] + XOR DX,DX + XOR CX,CX + INT 21H + JC @@Error + + PUSH AX + PUSH DX + + MOV AX,4202H + XOR DX,DX + XOR CX,CX + INT 21H + JC @@Error + + POP DI + POP SI + PUSH AX + PUSH DX + + MOV AX,4200H + MOV DX,SI + MOV CX,DI + INT 21H + JC @@Error + + MOV [LastError],0H + POP DX + POP AX + JMP @@Done + +@@Error: + MOV [LastError],AX + +@@Done: +END; + +FUNCTION DOSFileEnd(VAR UserFileHandle: TDOSFileHandle): BOOLEAN; +ASSEMBLER; +ASM + MOV AX,4201H + LES DI,[UserFileHandle] + MOV BX,[TDOSFileHandle(ES:DI).Number] + XOR DX,DX + XOR CX,CX + INT 21H + JC @@Error + + PUSH AX + PUSH DX + + MOV AX,4202H + XOR DX,DX + XOR CX,CX + INT 21H + JC @@Error + + POP DI + POP SI + PUSH AX + PUSH DX + + MOV AX,4200H + MOV DX,SI + MOV CX,DI + INT 21H + JC @@Error + + MOV [LastError],0H + POP DX + POP AX + CMP DI,DX + JA @@BeyondEnd + JB @@BeforeEnd + + CMP SI,AX + JB @@BeforeEnd + +@@BeyondEnd: + MOV AL,1 + JMP @@Done + +@@BeforeEnd: + XOR AL,AL + JMP @@Done + +@@Error: + MOV [LastError],AX + +@@Done: +END; + +PROCEDURE DOSFileDelete(FileName: STRING); +ASSEMBLER; +VAR + PathBuffer: ARRAY[0..78] OF CHAR; +ASM + PUSH DS + + CLD + + MOV AX,[WORD PTR FileName+2] + MOV SI,[WORD PTR FileName] + LEA DI,PathBuffer + MOV DX,DI + MOV DS,AX + MOV BX,SS + MOV ES,BX + + LODSB + XOR AH,AH + MOV CX,AX + CMP CL,79 + JBE @@MoveThem + + MOV CL,79 + +@@MoveThem: + SHR CX,1 + JNC @@DoWords + + MOVSB + +@@DoWords: + REP MOVSW + + MOV [BYTE PTR ES:DI],0H + + MOV AX,ES + MOV DS,AX + MOV AH,41H + MOV CL,0 + INT 21H + POP DS + JC @@Error + + MOV [LastError],0 + JMP @@Done + +@@Error: + MOV [LastError],AX + +@@Done: +END; + +PROCEDURE DOSFileRename(FileName, NewFileName: STRING); +ASSEMBLER; +VAR + PathBuffer1: ARRAY[0..78] OF CHAR; + PathBuffer2: ARRAY[0..78] OF CHAR; +ASM + PUSH DS + + CLD + + MOV AX,[WORD PTR FileName+2] + MOV SI,[WORD PTR FileName] + LEA DI,PathBuffer1 + MOV DX,DI + MOV DS,AX + MOV BX,SS + MOV ES,BX + + LODSB + XOR AH,AH + MOV CX,AX + CMP CL,79 + JBE @@MoveThem + + MOV CL,79 + +@@MoveThem: + SHR CX,1 + JNC @@DoWords + + MOVSB + +@@DoWords: + REP MOVSW + + MOV [BYTE PTR ES:DI],0H + + MOV AX,[WORD PTR NewFileName+2] + MOV SI,[WORD PTR NewFileName] + LEA DI,PathBuffer2 + MOV DS,AX + + LODSB + XOR AH,AH + MOV CX,AX + CMP CL,79 + JBE @@MoveThem2 + + MOV CL,79 + +@@MoveThem2: + SHR CX,1 + JNC @@DoWords2 + + MOVSB + +@@DoWords2: + REP MOVSW + + MOV [BYTE PTR ES:DI],0H + + MOV AX,ES + MOV DS,AX + LEA DI,PathBuffer2 + MOV AH,56H + MOV CL,0 + INT 21H + POP DS + JC @@Error + + MOV [LastError],0 + JMP @@Done + +@@Error: + MOV [LastError],AX + +@@Done: +END; + +PROCEDURE DOSDiskCurrentSet(DiskDrive: BYTE); +ASSEMBLER; +ASM + MOV AH,0EH + MOV DL,[DiskDrive] + INT 21H + + MOV [LastError],0H +END; + +FUNCTION DOSDiskCurrentGet: BYTE; +ASSEMBLER; +ASM + MOV AH,19H + INT 21H + + MOV [LastError],0H +END; + +FUNCTION DOSDiskValidCount: BYTE; +ASSEMBLER; +ASM + MOV AH,19H + INT 21H + + MOV AH,0EH + MOV DL,AL + INT 21H + + MOV [LastError],0H +END; + +FUNCTION DOSDiskSpaceFree(DiskDrive: BYTE): LONGINT; +ASSEMBLER; +ASM + MOV AH,36H + MOV DL,[DiskDrive] + INT 21H + CMP AX,0FFFFH + JE @@Error + + MUL CX + MUL BX + MOV [LastError],0 + JMP @@Done + +@@Error: + MOV AH,59H + XOR BX,BX + INT 21H + MOV [LastError],AX + +@@Done: +END; + +FUNCTION DOSDiskSpaceTotal(DiskDrive: BYTE): LONGINT; +ASSEMBLER; +ASM + MOV AH,36H + MOV DL,[DiskDrive] + INT 21H + CMP AX,0FFFFH + JE @@Error + + MOV BX,DX + MUL CX + MUL BX + MOV [LastError],0 + JMP @@Done + +@@Error: + MOV AH,59H + XOR BX,BX + INT 21H + MOV [LastError],AX + +@@Done: +END; + +PROCEDURE DOSMemoryAllocate(VAR DOSMemoryHandle: TDOSMemoryHandle; Size: WORD); +ASSEMBLER; +ASM + LES DI,[DOSMemoryHandle] + MOV AH,48H + MOV BX,[Size] + INT 21H + JC @@Error + + MOV [TDOSMemoryHandle(ES:DI).Segment],AX + MOV [TDOSMemoryHandle(ES:DI).Offs],0H + MOV [LastError],0H + JMP @@Done + +@@Error: + MOV [LastError],AX + MOV [TDOSMemoryHandle(ES:DI).Segment],0H + MOV [TDOSMemoryHandle(ES:DI).Offs],0H + +@@Done: +END; + +FUNCTION DOSMemoryAvail: WORD; +ASSEMBLER; +ASM + MOV AH,48H + MOV BX,0FFFFH + INT 21H + + MOV [LastError],0H + + MOV AX,BX +END; + +PROCEDURE DOSMemoryDeallocate(VAR DOSMemoryHandle: TDOSMemoryHandle); +ASSEMBLER; +ASM + LES DI,[DOSMemoryHandle] + MOV DX,ES + MOV AX,[TDOSMemoryHandle(ES:DI).Segment] + MOV ES,AX + MOV AH,49H + INT 21H + MOV ES,DX + JC @@Error + + MOV [TDOSMemoryHandle(ES:DI).Segment],0H + MOV [TDOSMemoryHandle(ES:DI).Offs],0H + MOV [LastError],0H + JMP @@Done + +@@Error: + MOV [LastError],AX + +@@Done: +END; + +BEGIN + ASM + MOV AH,34H + INT 21H + + MOV [WORD PTR InDOSFlagPtr],BX + MOV BX,ES + MOV [WORD PTR InDOSFlagPtr+2],BX + + MOV [LastError],0H + END; +END. \ No newline at end of file diff --git a/UNITS/DPMI.PAS b/UNITS/DPMI.PAS new file mode 100644 index 0000000..884c3a0 --- /dev/null +++ b/UNITS/DPMI.PAS @@ -0,0 +1,670 @@ +{$S-,R-,V-,I-,B-,F+} + +{$IFNDEF Ver40} + {$R-,O-,A-} +{$ENDIF} + +{*********************************************************} +{* DPMI.PAS 1.00 *} +{* Copyright (c) TurboPower Software 1992. *} +{* All rights reserved. *} +{*********************************************************} + +unit Dpmi; {primitive routines for DPMI management} + +interface + +{-The following consts are used throughout Object Professional. Your code + is free to reference them, but they must *not* be changed.} +const + DpmiInUse : Boolean = False; {True if running in protected mode} + ColorSele : Word = $B800; {selector/segment for color video} + MonoSele : Word = $B000; {selector/segment for mono video} + BiosDataSele : Word = $0040; {selector/segment for bios data area} + BiosSele : Word = $F000; {selector/segment for bios memory} + + +{$IFDEF Dpmi} +type + {.Z+} + DoubleWord = record + LoWord : Word; + HiWord : Word; + end; + + DPMIRegisters = + record + DI : LongInt; + SI : LongInt; + BP : LongInt; + Reserved : LongInt; + BX : LongInt; + DX : LongInt; + CX : LongInt; + AX : LongInt; + Flags : Word; + ES : Word; + DS : Word; + FS : Word; + GS : Word; + IP : Word; + CS : Word; + SP : Word; + SS : Word; + end; + + MemInfoRec = + record + LargestFreeBlock : LongInt; + MaxUnlockedPages : LongInt; + MaxLockedPages : LongInt; + LinearAddrPages : LongInt; + TotalUnlockedPages : LongInt; + TotalFreePages : LongInt; + TotalPhysicalPages : LongInt; + FreeLinearPages : LongInt; + PageSize : LongInt; + Reserved : Array[1..$C] of Byte; + end; + + DPMIInfoRec = + record {Information returned by GetDPMIInfo routine} + MinorVersion : Byte; + MajorVersion : Byte; + Flags : Word; + SlavePICInt : Byte; + MasterPICInt : Byte; + Processor : Byte; + end; + +type + DescriptorTableEntry = + record + LimitL : Word; + BaseL : Word; + Words : Array[0..1] of Word; + end; + {.Z-} + +function Linear(P : Pointer) : LongInt; + {-Converts a pointer to a linear address to allow differences in addresses + to be calculated. The pointer must be in the range $0:$0 to $FFFF:$000F.} + +function UnLinear(L : LongInt) : Pointer; + {-Converts a linear address to a pointer to allow selector base addresses to + be converted to pointers. The longInt must be in the range $0 to $000FFFFF.} + +function AllocLDTDescriptors(NumOfDesc : Word; var BaseSelector : Word) : Word; + {-Allocates one or more descriptors in the task's Local Descriptor Table + (LDT). The descriptor is not initialized; this must be done with calls to + SetSegmentBaseAddr and SetSegmentLimit. The allocated descriptor will be + set to "data" with a priviledge level equal to the application's code + segment priviledge level. If requesting more than one descriptor, the + BaseSelector will be set to the first of a contiguous array of + descriptors. The Selector values for subsequent descriptors in the array + must be calculated by adding the value returned by GetSelectorIncrement.} + +function GetSelectorIncrement : Word; + {-gets the selector increment value} + +function SetSegmentBaseAddr(Selector : Word; BaseAddress : LongInt) : Word; + {-Sets the base (starting) address for Selector} + +function SetSegmentLimit(Selector : Word; Limit : LongInt) : Word; + {-Sets the limit (length) for Selector} + +function GetSegmentBaseAddr(Selector : Word; var BaseAddress: LongInt) : Word; + {-Gets the base (starting) address for Selector} + +function GetSegmentLimit(Selector : Word; var Limit : LongInt) : Word; + {-Gets the limit (length) for Selector} + +function FreeLDTDescriptor(Selector : Word) : Word; + {-Deallocates Selector} + +function GetSelectorForRealMem(RealPtr : Pointer; Limit : LongInt; var Selector : Word) : Word; + {-Allocates Selector of Size bytes in Real memory, starting at RealPtr} + +function GetDescriptor(Selector : Word; + var Descriptor : DescriptorTableEntry) : Word; + {-Gets the Descriptor Table information on Selector, returns 0 if successful} + +function CallFarRealModeProc(StackWords : Word; StackData : Pointer; + var Regs : DPMIRegisters) : Word; + {-Simulates a FAR CALL to a real mode procedure.} + +function SimulateRealModeInt(IntNo : Byte; + var Regs : DPMIRegisters) : Word; + {-Simulates an interrupt in real mode. Control is transferred to the + address specified by the real mode interrupt vector.} + +procedure GetRealModeIntVector(IntNo : Byte; var Vector : Pointer); + {-Returns the contents of the current virtual machine's real mode interrupt + vector number for IntNo. Note, the returned address is a real mode + segment:offset.} + +procedure SetRealModeIntVector(IntNo : Byte; Vector : Pointer); + {-Set the current virtual machine's real mode interrupt vector for + vector IntNo. Vector must be a real mode segment:offset.} + +function AllocRealModeCallbackAddr(CallbackProc : Pointer; + var Regs : DPMIRegisters; + var Callback : Pointer) : Word; + {-Allocates a unique real mode segment:offset that will transfer control + from real mode to a protected mode procedure.} + +function FreeRealModeCallbackAddr(Callback : Pointer) : Word; + {-Frees a real mode callback previously allocated with + AllocateRealModeCallbackAddr.} + +procedure GetProtectedModeInt(IntNo : Byte; var Handler : Pointer); + {-Returns the address of the current protected mode interrupt handler for + IntNo.} + +function SetProtectedModeInt(IntNo : Byte; Handler : Pointer) : Word; + {-Sets the address of the protected mode handler for IntNo.} + +procedure GetDPMIMemInfo(var MemInfo : MemInfoRec); + {-Returns information about the amount of available physical memory, linear + address space, and disk space for page swapping. See the MemInfoRec + declared above for information on the returned values. Only the first + field of the MemInfoRec is guantanteed to be valid. All invalid fields + will be set to -1.} + +{$ENDIF} + +implementation + + +{$IFDEF Dpmi} +type + OS = + record + O, S : Word; + end; + +var + DpmiPrimExitPtr : Pointer; + + function Linear(P : Pointer) : LongInt; + {-Converts a pointer to a linear address to allow differences in addresses + to be calculated. The pointer must be in the range $0:$0 to $FFFF:$000F.} + begin + with OS(P) do + Linear := (LongInt(S) shl 4)+LongInt(O); + end; + + function UnLinear(L : LongInt) : Pointer; + {-Converts a linear address to a pointer allow selector base addresses to + be converted to pointers. The longInt must be in the range $0 to $000FFFFF.} + begin + UnLinear := Ptr(Word(L shr 4), Word(L and $000F)); {!!.21} + end; + + function CallFarRealModeProc(StackWords : Word; StackData : Pointer; + var Regs : DPMIRegisters) : Word; Assembler; + asm + push ds + mov cx,StackWords + jcxz @@NoParams + lds si,StackData + mov ax,cx + dec ax + shl ax,1 + add si,ax + std + @@ParamLoop: + lodsw + push ax + loop @@ParamLoop + @@NoParams: + cld + xor bx,bx + mov cx,StackWords + les di,Regs + mov ax,0301h + int 31h + jc @@ExitPoint + xor ax,ax + @@ExitPoint: + mov bx,StackWords + shl bx,1 + add sp,bx + pop ds + end; + + function SimulateRealModeInt(IntNo : Byte; + var Regs : DPMIRegisters) : Word; Assembler; + asm + xor bx,bx + mov bl,IntNo + xor cx,cx {StackWords = 0} + les di,Regs + mov ax,0300h + int 31h + jc @@ExitPoint + xor ax,ax + @@ExitPoint: + end; + + procedure GetRealModeIntVector(IntNo : Byte; var Vector : Pointer); Assembler; + asm + mov ax,0200h + mov bl,IntNo + int 31h + les di,Vector + mov word ptr es:[di],dx + mov word ptr es:[di+2],cx + end; + + procedure SetRealModeIntVector(IntNo : Byte; Vector : Pointer); assembler; + asm + mov ax,$0201 + mov bl,IntNo + mov dx,word ptr Vector + mov cx,word ptr Vector+2 + int $31 + end; + + function GetCPUFlags : Byte; Assembler; + asm + lahf + mov al,ah + end; + + {Doesn't work under Windows 3.1. Don't use in Windows!} + function AllocDosMem(SizeInParas : Word; + var RealModeSeg : Word; + var ProtModeSel : Word) : Word; Assembler; + asm + mov bx,SizeInParas + mov ax,0100h + int 31h + jc @@ExitPoint + les di,RealModeSeg + mov es:[di],ax + les di,ProtModeSel + mov es:[di],dx + xor ax,ax + @@ExitPoint: + end; + + {Doesn't work under Windows 3.1. Don't use in Windows!} + function FreeDosMem(ProtModeSel : Word) : Word; Assembler; + asm + mov ax,0101h + mov dx,ProtModeSel + int 31h + jc @@ExitPoint + xor ax,ax + @@ExitPoint: + end; + + function AllocLDTDescriptors(NumOfDesc : Word; var BaseSelector : Word) : Word; Assembler; + asm + mov cx,NumOfDesc + xor ax,ax + int 31h + jc @@ExitPoint + les di,BaseSelector + mov es:[di],ax + xor ax,ax + @@ExitPoint: + end; + + function SetSegmentBaseAddr(Selector : Word; BaseAddress : LongInt) : Word; Assembler; + asm + mov bx,Selector + mov dx,word ptr BaseAddress + mov cx,word ptr BaseAddress+2 + mov ax,0007h + int 31h + jc @@ExitPoint + xor ax,ax + @@ExitPoint: + end; + + function GetSegmentAccessRights(Selector : Word; var Rights : Word) : Word; + var + Status : Word; + Descriptor : DescriptorTableEntry; + begin + Status := GetDescriptor(Selector, Descriptor); + if Status = 0 then + with Descriptor do + Rights := (Words[0] shr 8) or ((Words[1] and $00F0) shl 8); + GetSegmentAccessRights := Status; + end; + + function SetRightsPrim(Selector : Word; Rights : Word) : Word; Assembler; + {-Primitive rights change} + asm + mov bx,Selector + mov cx,Rights + mov ax,0009h + int 31h + jc @@ExitPoint + xor ax,ax + @@ExitPoint: + end; + + function SetSegmentAccessRights(Selector : Word; + ReadWrite : WordBool; Code : WordBool) : Word; + var + Rights : Word; + Status : Word; + begin + Status := GetSegmentAccessRights(Selector, Rights); + if Status <> 0 then begin + SetSegmentAccessRights := Status; + Exit; + end; + + {Modify the Rights mask according to parameters} + if Code then begin + ReadWrite := True; {For code, means segment can be read as well as executed} + Rights := Rights and not $0004; {Code is always expand-up} + Rights := Rights or $0008; {Set Code bit} + end else + Rights := Rights and not $0008; {Clear Code bit} + if ReadWrite then + Rights := Rights or $0002 {Set ReadWrite bit} + else + Rights := Rights and not $0002; {Clear ReadWrite bit} + + {Change the rights} + SetSegmentAccessRights := SetRightsPrim(Selector, Rights); + end; + + function GetSegmentLimit(Selector : Word; var Limit : LongInt) : Word; + var + Status : Word; + Descriptor : DescriptorTableEntry; + begin + Status := GetDescriptor(Selector, Descriptor); + if Status = 0 then + with Descriptor do begin + Limit := LongInt(LimitL) or (LongInt(Words[1] and $0F) shl 16); + {Account for granularity} + if Words[1] and $80 <> 0 then + Limit := Limit*4096; + end; + GetSegmentLimit := Status; + end; + + function GetSegmentBaseAddr(Selector : Word; var BaseAddress : LongInt) : Word; Assembler; + asm + mov bx,Selector + mov ax,0006h + int 31h + jc @@ExitPoint + xor ax,ax + les di,BaseAddress + mov es:[di],dx + mov es:[di+2],cx + @@ExitPoint: + end; + + function SetLimitPrim(Selector : Word; Limit : LongInt) : Word; Assembler; + {-Primitive limit change} + asm + mov bx,Selector + mov dx,word ptr Limit + mov cx,word ptr Limit+2 + mov ax,0008h + int 31h + jc @@ExitPoint + xor ax,ax + @@ExitPoint: + end; + + function SetSegmentLimit(Selector : Word; Limit : LongInt) : Word; + var + Rights : Word; + Status : Word; + begin + {Handle limit granularity} + Status := GetSegmentAccessRights(Selector, Rights); + if Status <> 0 then begin + SetSegmentLimit := Status; + Exit; + end; + if Limit > $FFFFF then begin + {Segment larger than 1MB} + if Limit and $FFF <> $FFF then begin + {Not page aligned} + SetSegmentLimit := $8021; + Exit; + end; + Rights := Rights or $8000; {Page-granular} + end else + Rights := Rights and not $8000; {Byte-granular} + + {Assure no overflow when granularity changed} + Status := SetLimitPrim(Selector, 0); + if Status = 0 then + Status := SetRightsPrim(Selector, Rights); + if Status = 0 then + SetSegmentLimit := SetLimitPrim(Selector, Limit); + SetSegmentLimit := Status; + end; + + function FreeLDTDescriptor(Selector : Word) : Word; Assembler; + asm + mov bx,Selector + mov ax,0001h + int 31h + jc @@ExitPoint + xor ax,ax + @@ExitPoint: + end; + + function GetSelectorIncrement : Word; Assembler; + asm + mov ax,0003h + int 31h + end; + + function GetSelectorForRealMem(RealPtr : Pointer; Limit : LongInt; var Selector : Word) : Word; + + procedure FreeSele; + begin + FreeLDTDescriptor(Selector); + end; + + var + ErrorCode : Word; + + begin + ErrorCode := AllocLDTDescriptors(1, Selector); + if ErrorCode = 0 then begin + ErrorCode := SetSegmentBaseAddr(Selector, Linear(RealPtr)); + if ErrorCode = 0 then begin + ErrorCode := SetSegmentLimit(Selector, Limit); + if ErrorCode <> 0 then + FreeSele; + end + else + FreeSele; + end; + GetSelectorForRealMem := ErrorCode; + end; + + function AllocRealModeCallbackAddr(CallbackProc : Pointer; + var Regs : DPMIRegisters; + var Callback : Pointer) : Word; Assembler; + asm + push ds + lds si,CallbackProc + les di,Regs + mov ax,0303h + int 31h + jnc @@Exitpoint + xor cx,cx + xor dx,dx + jmp @@ExitPoint2 + @@ExitPoint: + xor ax,ax + @@ExitPoint2: + les di,Callback + mov word ptr es:[di],dx + mov word ptr es:[di+2],cx + pop ds + end; + + function FreeRealModeCallbackAddr(Callback : Pointer) : Word; Assembler; + asm + mov cx,word ptr Callback+2 + mov dx,word ptr Callback + mov ax,0304h + int 31h + jc @@ExitPoint + xor ax,ax + @@ExitPoint: + end; + + procedure GetProtectedModeInt(IntNo : Byte; var Handler : Pointer); Assembler; + asm + mov ax,0204h + mov bl,IntNo + int 31h + les di,Handler + mov word ptr es:[di],dx + mov word ptr es:[di+2],cx + end; + + function SetProtectedModeInt(IntNo : Byte; Handler : Pointer) : Word; Assembler; + asm + mov bl,IntNo + mov dx,word ptr Handler + mov cx,word ptr Handler+2 + mov ax,0205h + int 31h + jc @@ExitPoint + xor ax,ax + @@ExitPoint: + end; + + function GetExceptionHandler(ExceptionNum : Byte; + var Handler : Pointer) : Word; Assembler; + asm + mov bl,ExceptionNum + mov ax,0202h + int 31h + jc @@ExitPoint + xor ax,ax + les di,Handler + mov word ptr es:[di],dx + mov word ptr es:[di+2],cx + @@ExitPoint: + end; + + function SetExceptionHandler(ExceptionNum : Byte; + Handler : Pointer) : Word; Assembler; + asm + mov bl,ExceptionNum + mov ax,0203h + mov dx,word ptr Handler + mov cx,word ptr Handler+2 + int 31h + jc @@ExitPoint + xor ax,ax + @@ExitPoint: + end; + + + procedure GetDPMIMemInfo(var MemInfo : MemInfoRec); Assembler; + const + SizeOfMemInfoRec = SizeOf(MemInfoRec); + asm + les di,MemInfo + mov si,di + mov cx,SizeOfMemInfoRec + mov al,0FFh + cld + rep stosb {set record to -1 in case DPMI doesn't} + mov di,si + mov ax,0500h {get free memory info} + int 31h {this function doesn't fail} + mov ax,0604h {get page size} + int 31h + jc @@ExitPoint {not supported by 16-bit hosts} + lea di,MemInfoRec(es:[si]).PageSize + cld + mov ax,cx + stosw + mov ax,bx + stosw + @@ExitPoint: + end; + + procedure GetDPMIInfo(var DPMIInfo : DPMIInfoRec); Assembler; + asm + mov ax,0400h + int 31h {this function doesn't fail} + les di,DPMIInfo + cld + stosw {store minor and major version numbers} + mov ax,bx + stosw {store Flags} + mov ax,dx + stosw {store PIC base interrupt numbers} + mov al,cl + stosb {store processor type} + end; + + function GetPageSize(var PageSize : LongInt) : Word; Assembler; + asm + mov ax,0604h + int 31h + jc @@ExitPoint + les di,PageSize + mov es:[di],cx + mov es:[di+2],bx + xor ax,ax + @@ExitPoint: + end; + + function GetDescriptor(Selector : Word; + var Descriptor : DescriptorTableEntry) : Word; Assembler; + asm + mov ax,000Bh + mov bx,Selector + les di,Descriptor + int 31h + jc @@ExitPoint + xor ax,ax + @@ExitPoint: + end; + + procedure DpmiPrimExitProc; + {-Our exit handler for this unit} + begin + ExitProc := DpmiPrimExitPtr; + + {free our BiosSele selector} + FreeLDTDescriptor(BiosSele); + end; + +var + W : Word; + +begin + ColorSele := SegB800; + MonoSele := SegB000; + BiosDataSele := Seg0040; + DpmiInUse := True; + + {since the RTL doesn't provide an important predefined selector, we get one} + W := GetSelectorForRealMem(Ptr($F000, 0), $FFFF, BiosSele); + if W <> 0 then + {failed; generate Runtime Error 203 (out of heap)} + RunError(203) + else begin + {and set up an exit handler to release it} + DpmiPrimExitPtr := ExitProc; + ExitProc := @DpmiPrimExitProc; + end; +{$ENDIF} +end. + diff --git a/UNITS/FLASH/ACTING.PAS b/UNITS/FLASH/ACTING.PAS new file mode 100644 index 0000000..2e5dff2 --- /dev/null +++ b/UNITS/FLASH/ACTING.PAS @@ -0,0 +1,250 @@ +Unit acting; + +interface + + uses flobjects; + +Const + cDefaultAct = '#default'; + cDescribe = '#describe'; + cDoTalk = '#talkto'; + cEX_PREFIX = 'DEL_'; + + Listsize=32; +type + listrec=record + listname:string[16]; + Kind:(grel,orel); + end; + plist=^tlist; + tlist=record + length:byte; + listing:array[0..listsize-1] of listrec; + end; + +procedure dirdefaultact(dirname:string); +procedure act_default(obj:pFlashCommon); +procedure act_list(obj:pFlashCommon); + +implementation + +uses objects,core,misc,types,constants, + tpstr,flashcom,flaction, + fx_mouse,fx_init,flgraph,fx_form,play,sounds; + + +procedure dirdefaultact(dirname:string); + var comm:pCommands; +begin + comm:=currentloc^.acts^.getname(dirname); + if comm=nil + then Message('нет выхода '+dirname) + else begin + comm^.run; + Atmo^.TimeLine^.ProcessEvents; + end; +end; + +procedure act_default(obj:pFlashCommon); + var cm:pCommands; +begin + case obj^.Kind of + nTHING: begin + CurrentThing:=obj^.Name; + cm:=obj^.acts^.getname(cDefaultAct); + if cm<>nil + then cm^.run + else MessageWindow(PTHING(obj)^.text); + Atmo^.TimeLine^.ProcessEvents; + end; + nLOC : begin + cm:=obj^.acts^.getname(cDescribe); + if cm<>nil + then cm^.run + else MessageWindow(PLocation(obj)^.text); + Atmo^.TimeLine^.ProcessEvents; + end; + nHUMAN: begin + cm:=obj^.acts^.getname(cDOTALK); + if cm<>nil + then cm^.run + else MessageWindow(PHuman(obj)^.text); + Atmo^.TimeLine^.ProcessEvents; + end; + end; +end; + + +procedure add_orel(obj:pFlashCommon; var list:tlist); + var a:integer; + name:pstring; + +function must_exclude(act:nstring):boolean; +begin + if PFlashCommon(Obj)^.Params^.SearchRec(cEX_PREFIX+Act)<>nil + then must_exclude:=true + else must_exclude:=false; +end; + +begin + for a:=0 to obj^.acts^.commands^.count-1 do + begin + name:=PCommands(obj^.acts^.commands^.at(a))^.name; + if (name<>nil) and (name^[1]<>'#') and (not must_exclude(name^)) + then if list.length=listsize + then ErrorMSG(Str2Pchar('Can`t add orel to list for '+obj^.name)) + else begin + list.listing[list.length].listname:=name^; + list.listing[list.length].Kind:=orel; + inc(list.length); + end; + end; +end; + + +procedure add_grel(obj:pFlashCommon; var list:tlist); + var a:integer; + name:IdentString; + PlayName:TString; + +function must_exclude(act:nstring):boolean; +begin + if PFlashCommon + (Obj)^.Params^.SearchRec(cEX_PREFIX+Act)<>nil + then must_exclude:=true + else must_exclude:=false; +end; + +begin + for a:=0 to actlist^.count-1 do + begin + name:=actlist^.get(a)^.name; + if (name[1]<>'#') and (not must_exclude(name)) + then if list.length=listsize + then ErrorMSG(Str2Pchar('Can`t add grel '+name+' for unkown')) + else begin + list.listing[list.length].listname:=name; + list.listing[list.length].Kind:=grel; + inc(list.length); + end; + end; +end; + +procedure make_list(obj:pFlashCommon; var list:tlist); +begin + list.length:=0; + case obj^.Kind of + nTHING:begin + CurrentThing:=obj^.Name; + add_grel(obj,list); + add_orel(obj,list); + end; + nLOC :begin + CurrentThing:=obj^.Name; + add_orel(obj,list); + end; + nHUMAN:begin + CurrentThing:=obj^.Name; + add_orel(obj,list); + add_grel(obj,list); + end; + end; +end; + +function choose(butt:pbutton_line):integer; + var i:integer; + x,y:word; +begin + hide_mouse; + if butt^.viewed then butt^.hide; + if not butt^.viewed then begin + + if butt^.height+5+mouseposy>Screen^.height + then y:=Screen^.height-butt^.height-1 + else begin + if MousePOSY>10 + then y:=MousePOSY-10 + else y:=mouseposy; + end; + + if butt^.width+5+mouseposx>Screen^.Width + then x:=Screen^.Width-butt^.width-1 + else begin + if MousePOSX>10 + then X:=MousePOSX-10 + else X:=mouseposX; + end; + + butt^.show(x,y); + end; + show_mouse; + while true do begin + + if mousebuttons=02 then begin + while mousebuttons<>0 do; + choose:=-1; + exit; + end; + + if mousebuttons=01 + then begin + i:=butt^.pressed(mouseposx,mouseposy); + if i<>-1 then begin + PlaySound(sndClick); + choose:=i; + while mousebuttons<>0 do; + exit; + end else while mousebuttons<>0 do; + end; + end; +end; + +procedure act_list(obj:pFlashCommon); +var + list:plist; + butt:pbutton_line; + c:byte; + a,wasb,len,len1:integer; +begin + new(list); + make_list(obj,list^); + if list^.length=0 then begin + dispose(list); + exit; + end; + if list^.length<10 + then c:=list^.length + else c:=10; + + len:=LightFont^.lnWidth(obj^.playname); + for a:=0 to list^.length-1 do begin + len1:=LightFont^.lnWidth(list^.listing[a].listname); + if len1>len then len:=len1; + end; + + new(butt,init(c,len+15,obj^.playname)); + for a:=0 to list^.length-1 do + case list^.listing[a].kind of + orel : butt^.add_butt(list^.listing[a].listname); + grel : butt^.add_butt(actlist^.find(list^.listing[a].listname)^.playname); + end; + wasb:=butt^.buttons; + a:=choose(butt); + hide_mouse; + dispose(butt,done); + show_mouse; + if (a<>-1) and (a<>wasb) then + case list^.listing[a].Kind of + orel : begin + obj^.acts^.getname(list^.listing[a].listname)^.run; + Atmo^.TimeLine^.ProcessEvents; + end; + grel : begin + pact(actlist^.find(list^.listing[a].listname))^.run(obj^.name); + Atmo^.TimeLine^.ProcessEvents; + end; + end; + dispose(list); +end; + +end. \ No newline at end of file diff --git a/UNITS/FLASH/APPDLL.PAS b/UNITS/FLASH/APPDLL.PAS new file mode 100644 index 0000000..ac61f30 --- /dev/null +++ b/UNITS/FLASH/APPDLL.PAS @@ -0,0 +1,65 @@ +Unit AppDll; + + interface + + const AppLib = 'APPLETS'; + + procedure CallExternal(Id:Integer); + + procedure FeatureProc1; + procedure FeatureProc2; + procedure FeatureProc3; + procedure FeatureProc4; + procedure FeatureProc5; + procedure FeatureProc6; + procedure FeatureProc7; + procedure FeatureProc8; + procedure FeatureProc9; + procedure FeatureProc10; + + implementation + + uses flgraph,fx_mouse,status,fx_shape,fx_init,flscript,flobjects; + + procedure CallExternal(Id:Integer); + begin + clip; + Done_status; + DoneMouseHandler; + Palette^.FadeTo(Black^,8); + ClearGr; + Palette^.Apply; + case id of + 1 : FeatureProc1; + 2 : FeatureProc2; + 3 : FeatureProc3; + 4 : FeatureProc4; + 5 : FeatureProc5; + 6 : FeatureProc6; + 7 : FeatureProc7; + 8 : FeatureProc8; + 9 : FeatureProc9; + 10: FeatureProc10; + end; + InitMouseHandler(new(pcursor,load(res^.loadres('stCURSOR')^))); + Black^.Apply; + clipoff; + dofadeloc:=false; + updatelocation(CurrentLoc); + dofadeloc:=true; + Palette^.FadeFrom(Black^,8); + Show_mouse; + end; + + procedure FeatureProc1; external AppLib index 1; + procedure FeatureProc2; external AppLib index 2; + procedure FeatureProc3; external AppLib index 3; + procedure FeatureProc4; external AppLib index 4; + procedure FeatureProc5; external AppLib index 5; + procedure FeatureProc6; external AppLib index 6; + procedure FeatureProc7; external AppLib index 7; + procedure FeatureProc8; external AppLib index 8; + procedure FeatureProc9; external AppLib index 9; + procedure FeatureProc10; external AppLib index 10; + +end. diff --git a/UNITS/FLASH/AUDIO.PAS b/UNITS/FLASH/AUDIO.PAS new file mode 100644 index 0000000..d97ee43 --- /dev/null +++ b/UNITS/FLASH/AUDIO.PAS @@ -0,0 +1,657 @@ +Unit Audio; +{----------------------------------------------------------------------------} +{ Audio : An implementation of a Soundblaster-pro driver (BP 7.0). The } +{ Soundblaster-Pro object features record and playback using DMA } +{ so your CPU can do something else while sound is being played } +{ or recorded. Both Real and Protected Mode are supported. } +{ This code has only been tested on a Soundblaster-Pro clone with } +{ BasePort=$220, Irq=7 and DMAchannel=1. } +{ Do what ever you like with this code, but use it at your own } +{ risk!!!!! } +{ Comments and/or bug fixes are welcome at the e-mail address below } +{****************************************************************************} +{ Author : Menno Victor van der star } +{ E-mail : s795238@dutiwy.twi.tudelft.nl } +{ Developed on : 08-02-'95 } +{ Last update on : 13-06-'95 } +{ Status : Working, but only tested on a SB-pro clone with } +{ Baseport=$220, Irq=7 and DMAChannel=1 } +{ Future extensions : - Direct input/output filter for playing .WAV/.VOC's } +{ - Extensive testing (Feedback appreciated :) } +{----------------------------------------------------------------------------} +Interface + +{$IFDEF DPMI} Uses WinAPI; {$ENDIF} + +Const +{-- Constants for soundblaster-pro object --} + + Stereo = True; { Stereo/Mono constants } + Mono = False; + + Master = 0; { Volume/Input devices } + Microphone = 1; + CDAudio = 2; + LineIn = 3; + Voice = 4; + FM = 5; + + Left = 0; { Indications for left, right or both channels } + Right = 1; + LeftAndRight = 2; + + HighPass = 0; { Bandpass filter constants } + LowPass = 1; + +Type + PSoundBlasterPro = ^SoundBlasterPro; + SoundBlasterPro = Object + + Constructor Init (Port, IRQ, DMA : Word); + Destructor Done; Virtual; + + { The following 4 virtual procedures have to be redefined via inheritance : + - OutBuffer : Write 'Size' recorded bytes from 'Buffer' + - InBuffer : Read 'Size' bytes to be played back from 'Buffer' + - RecordingReady : This procedure is called after the recording is done + - PlaybackReady : This procedure is called after the sound has been played } + + Procedure OutBuffer (Var Buffer; Size : Word); Virtual; + Procedure InBuffer (Var Buffer; Size : Word); Virtual; + Procedure RecordingReady; Virtual; + Procedure PlaybackReady; Virtual; + + Function Reset : Boolean; + Procedure PlaySample (SampleRate : Word; Length : LongInt); + Procedure RecordSample (SampleRate : Word; Length : LongInt); + + Procedure SetStereoIn; + Procedure SetMonoIn; + Function InputMode : Boolean; + + Procedure SetVolume (VolumeType, Channel, Volume : Byte); + Function GetVolume (VolumeType, Channel : Byte) : Byte; + Procedure SetInput (InputDevice, Filter : Byte; FilterOn : Boolean); + Procedure GetInput (Var InputDevice, Filter : Byte; Var FilterOn : Boolean); + Procedure SetOutput (StereoOut, FilterOutput : Boolean); + Procedure GetOutput (Var StereoOut, FilterOutput : Boolean); + + Procedure HandleRecordIrq; + Procedure HandlePlaybackIrq; + + Private + + DMAChannel, IrqVector, IrqIntVector, SBPort, PICPort, + ResetPort, ReadPort, WritePort, PollPort, MixerIndexPort, + MixerWritePort : Word; + OldIntVector, DMABuffer1, DMABuffer2, SoundBuffer1, SoundBuffer2 : Pointer; + IRQStopMask, IRQStartMask, DMAStartMask, DMAStopMask, + DMAModeReg : Byte; + + StereoMode : Boolean; + CurrentPlay, CurrentRecord : Pointer; + PlayLength, RecordLength : LongInt; + RecSampleSize, RecSampleRate, PlaySampleRate, PlaySampleSize : Word; + + Procedure WriteMixer (Index, Value : Byte); + Function ReadMixer (Index : Byte) : Byte; + Procedure WriteDSP (Value : Byte); + Function ReadDSP : Byte; + Procedure PlayBuffer (Buffer : Pointer; SampleRate : Word; Size : Word); + Procedure RecBuffer (Buffer : Pointer; SampleRate : Word; Size : Word); + Procedure EnableInterrupts; + Procedure DisableInterrupts; + Procedure DisableIrq; + Procedure EnableIrq; + + End; + +Implementation + +Uses Crt, Dos; + +Const + Module_ID = 'AUDIO'; + SBPro : PSoundBlasterPro = NIL; { Pointer to current soundblaster-pro object } + +Procedure RecordIRQ; Interrupt; + +Var + Dummy : Byte; + +Begin + Dummy:=Port [$22E]; { Maybe the value $22E should be replaced with the appropriate value } + { if a port other than $220 is used (I can't remember (anyone?)) } + If Assigned (SBPro) then SBPro^.HandleRecordIrq; + Port [$20]:=$20; +End; + +Procedure PlayIRQ; Interrupt; + +Var + Dummy : Byte; + +Begin + Dummy:=Port [$22E]; { Maybe the value $22E should be replaced with the appropriate value } + { if a port other than $220 is used (I can't remember (anyone?)) } + If Assigned (SBPro) then SBPro^.HandlePlaybackIrq; + Port [$20]:=$20; +End; + +Constructor SoundBlasterPro.Init (Port, IRQ, DMA : Word); + +Const + IrqIntNums : Array [0..15] Of Byte = ($08, $09, $0A, $0B, $0C, $0D, $0E, $0F, + $70, $71, $72, $73, $74, $75, $76, $77); +Var + l : LongInt; + +Begin + If Assigned (SBPro) then Fail; { Only one instance of the object is allowed at one time } + + DMAChannel:=DMA; + IrqVector:=IRQ; + SBPort:=Port; + If IrqVector<=7 then PICPort:=$21 Else PICPort := $A1; + IrqIntVector:=IrqIntNums[IrqVector]; + IrqStopMask:=1 SHL (IrqVector mod 8); + IrqStartMask:=Not IrqStopMask; + GetIntVec (IRQIntVector, OldIntVector); + + {$IFDEF DPMI} + + { This code looks a bit silly but I haven't had to time to clean it up } + + DMABuffer1:=Pointer (GlobalDosAlloc (32768)); + DMABuffer2:=Pointer (GlobalDosAlloc (32768)); + LongInt (DMABuffer1):=(LongInt (DMABuffer1) MOD 65536) SHL 16; + LongInt (DMABuffer2):=(LongInt (DMABuffer2) MOD 65536) SHL 16; + + SoundBuffer1:=Pointer (AllocSelector (LongInt (DMABuffer1) SHR 16)); + LongInt (SoundBuffer1):=LongInt (SoundBuffer1) SHL 16; + SoundBuffer2:=Pointer (AllocSelector (LongInt (DMABuffer2) SHR 16)); + LongInt (SoundBuffer2):=LongInt (SoundBuffer2) SHL 16; + + l:=GetSelectorBase (LongInt (SoundBuffer1) SHR 16); + If l MOD 65536>49152 then Begin + While l MOD 65536>0 Do Inc (l); + SetSelectorBase (LongInt (SoundBuffer1) SHR 16,l); + End; + + l:=GetSelectorBase (LongInt (SoundBuffer2) SHR 16); + If l MOD 65536>49152 then Begin + While l MOD 65536>0 Do Inc (l); + SetSelectorBase (LongInt (SoundBuffer2) SHR 16,l); + End; + + {$ELSE} + DMABuffer1:=NIL; + DMABuffer2:=NIL; + GetMem (DMABuffer1,32768); + GetMem (DMABuffer2,32768); + If Not Assigned (DMABuffer1) Or Not Assigned (DMABuffer2) then Begin Done; Fail; End; + l:=Seg (DMABuffer1^); l:=l*16; l:=l+Ofs (DMABuffer1^); + If l MOD 65536<=49152 then SoundBuffer1:=DMABuffer1 Else SoundBuffer1:=Ptr (((l DIV 65536)+1)*4096,0); + l:=Seg (DMABuffer2^); l:=l*16; l:=l+Ofs (DMABuffer2^); + If l MOD 65536<=49152 then SoundBuffer2:=DMABuffer2 Else SoundBuffer2:=Ptr (((l DIV 65536)+1)*4096,0); + {$ENDIF} + + ResetPort:=SBPort+$6; + ReadPort:=SBPort+$A; + WritePort:=SBPort+$C; + PollPort:=SBPort+$E; + MixerIndexPort:=SBPort+$4; + MixerWritePort:=SBPort+$5; + + DMAStartMask:=DMAChannel+$00; + DMAStopMask:=DMAChannel+$04; + DMAModeReg:=DMAChannel+$48; + + If Not Reset then Begin Done; Fail; End; + SetStereoIn; + SetVolume (Master,LeftAndRight,15); + SetVolume (Voice,LeftAndRight,15); + SetVolume (FM,LeftAndRight,15); + SetVolume (Microphone,Right,7); + SetVolume (CDAudio,LeftAndRight,15); + SetVolume (LineIn,LeftAndRight,15); + SetInput (LineIn,LowPass,True); + SetOutput (Stereo,True); + SBPro:=@SELF; + + DisableIrq; + SetIntVec (IRQIntVector, @PlayIrq); + EnableIrq; +End; + +Destructor SoundBlasterPro.Done; + +Begin + SetIntVec (IRQIntVector,OldIntVector); + {$IFDEF DPMI} + GlobalDosFree (LongInt (DMABuffer1) SHR 16); + GlobalDosFree (LongInt (DMABuffer2) SHR 16); + FreeSelector (LongInt (SoundBuffer1) SHR 16); + FreeSelector (LongInt (SoundBuffer2) SHR 16); + {$ELSE} + If Assigned (DMABuffer1) then FreeMem (DMABuffer1,32768); + If Assigned (DMABuffer2) then FreeMem (DMABuffer2,32768); + {$ENDIF} + SBPro:=NIL; +End; + +Procedure SoundBlasterPro.OutBuffer (Var Buffer; Size : Word); + +Begin + RunError (211); +End; + +Procedure SoundBlasterPro.InBuffer (Var Buffer; Size : Word); + +Begin + RunError (211); +End; + +Procedure SoundBlasterPro.RecordingReady; + +Begin + RunError (211); +End; + +Procedure SoundBlasterPro.PlaybackReady; + +Begin + RunError (211); +End; + +Function SoundBlasterPro.Reset : Boolean; + +Var + i : Byte; + +Begin + Port[ResetPort]:=1; + Delay (1); + Port[ResetPort]:=0; + i:=1; + While (ReadDSP<>$AA) And (i<100) Do Inc (i); + Reset:=i<100; + WriteMixer (0,0); +End; + +Procedure SoundBlasterPro.PlaySample (SampleRate : Word; Length : LongInt); + +Begin + PlayLength:=Length; + If PlayLength > 0 then Begin + DisableIrq; + SetIntVec (IRQIntVector, @PlayIrq); + EnableIrq; + CurrentPlay:=SoundBuffer1; + FillChar(SoundBuffer1^,16384,0); + FillChar(SoundBuffer2^,16384,0); + PlaySampleRate:=SampleRate; + If PlayLength >= 16384 then PlaySampleSize:=16384 Else PlaySampleSize:=PlayLength; + Dec (PlayLength,PlaySampleSize); + InBuffer (CurrentPlay^,PlaySampleSize); + PlayBuffer (CurrentPlay,SampleRate,PlaySampleSize); + If PlayLength > 0 then Begin + If PlayLength >= 16384 then PlaySampleSize:=16384 Else PlaySampleSize:=PlayLength; + Dec (PlayLength,PlaySampleSize); + InBuffer (SoundBuffer2^,PlaySampleSize); + End; + End; +End; + +Procedure SoundBlasterPro.RecordSample (SampleRate : Word; Length : LongInt); + +Begin + RecordLength:=Length; + If RecordLength > 0 then Begin + DisableIrq; + SetIntVec (IRQIntVector, @RecordIrq); + EnableIrq; + CurrentRecord:=SoundBuffer1; + RecSampleRate:=SampleRate; + If RecordLength >= 16384 then RecSampleSize:=16384 Else RecSampleSize:=RecordLength; + Dec (RecordLength,RecSampleSize); + RecBuffer (CurrentRecord,RecSampleRate,RecSampleSize); + End; +End; + +Procedure SoundBlasterPro.SetStereoIn; + +Begin + WriteDSP ($A8); + StereoMode:=Stereo; +End; + +Procedure SoundBlasterPro.SetMonoIn; + +Begin + WriteDSP ($A0); + StereoMode:=Mono; +End; + +Function SoundBlasterPro.InputMode : Boolean; + +Begin + InputMode:=StereoMode; +End; + +Procedure SoundBlasterPro.WriteMixer (Index, Value : Byte); + +Begin + Port [MixerIndexPort]:=Index; + Port [MixerWritePort]:=Value; +End; + +Function SoundBlasterPro.ReadMixer (Index : Byte) : Byte; + +Begin + Port [MixerIndexPort]:=Index; + ReadMixer:=Port [MixerWritePort]; +End; + +Procedure SoundBlasterPro.SetVolume (VolumeType, Channel, Volume : Byte); + +Var + IndexReg : Byte; + +Begin + If VolumeType<>Microphone then Begin + Case Channel Of + Left : Volume:=Volume SHL 4; + LeftAndRight : Volume:=Volume Or (Volume SHL 4); + End; + End; + Case VolumeType Of + Master : IndexReg:=$22; + Voice : IndexReg:=$4; + FM : IndexReg:=$26; + Microphone : IndexReg:=$0A; + CDAudio : IndexReg:=$28; + LineIn : IndexReg:=$2E; + End; + WriteMixer (IndexReg,Volume); +End; + +Function SoundBlasterPro.GetVolume (VolumeType, Channel : Byte) : Byte; + +Var + IndexReg, Volume : Byte; + +Begin + Case VolumeType Of + Master : IndexReg:=$22; + Voice : IndexReg:=$4; + FM : IndexReg:=$26; + Microphone : IndexReg:=$0A; + CDAudio : IndexReg:=$28; + LineIn : IndexReg:=$2E; + End; + Volume:=ReadMixer (IndexReg); + If (VolumeType<>Microphone) And (Channel=Left) then Volume:=Volume SHR 4; + If VolumeType=Microphone then Volume:=Volume And 7 Else Volume:=Volume And 15; + GetVolume:=Volume; +End; + +Procedure SoundBlasterPro.SetInput (InputDevice, Filter : Byte; FilterOn : Boolean); + +Var + Value : Byte; + +Begin + Case InputDevice Of + Microphone : Value:=0; + CDAudio : Value:=2; + LineIn : Value:=6; + Else + Exit; + End; + If Filter=LowPass then Value:=Value Or 8; + If Not FilterOn then Value:=Value Or 32; + WriteMixer ($0C,Value); +End; + +Procedure SoundBlasterPro.GetInput (Var InputDevice, Filter : Byte; Var FilterOn : Boolean); + +Var + Value : Byte; + +Begin + Value:=ReadMixer ($0C); + Case Value And 6 Of + 0 : InputDevice:=Microphone; + 2 : InputDevice:=CDAudio; + 6 : InputDevice:=LineIn; + End; + If Value And 8<>0 then Filter:=LowPass Else Filter:=HighPass; + FilterOn:=(Value And 32)=0 +End; + +Procedure SoundBlasterPro.SetOutput (StereoOut, FilterOutput : Boolean); + +Var + Value : Byte; + +Begin + If StereoOut then Value:=2 Else Value:=0; + If Not FilterOutput then Value:=Value Or 32; + WriteMixer ($0E,Value); +End; + +Procedure SoundBlasterPro.GetOutput (Var StereoOut, FilterOutput : Boolean); + +Var + Value : Byte; + +Begin + Value:=ReadMixer ($0E); + StereoOut:=(Value And 2)<>0; + FilterOutput:=(Value And 32)=0; +End; + +Procedure SoundBlasterPro.HandleRecordIrq; + +Begin + If RecordLength>0 then Begin + If CurrentRecord=SoundBuffer1 then CurrentRecord:=SoundBuffer2 Else CurrentRecord:=SoundBuffer1; + If RecordLength >= 16384 then RecSampleSize:=16384 Else RecSampleSize:=RecordLength; + Dec (RecordLength,RecSampleSize); + RecBuffer (CurrentRecord,RecSampleRate,RecSampleSize); + If CurrentRecord=SoundBuffer1 then OutBuffer (SoundBuffer2^,16384) Else OutBuffer (SoundBuffer1^,16384); + End + Else Begin + If CurrentRecord=SoundBuffer1 then + OutBuffer (SoundBuffer1^,RecSampleSize) + Else + OutBuffer (SoundBuffer2^,RecSampleSize); + RecordingReady; + End; +End; + +Procedure SoundBlasterPro.HandlePlaybackIrq; + +Begin + If PlayLength>0 then Begin + If CurrentPlay=SoundBuffer1 then CurrentPlay:=SoundBuffer2 Else CurrentPlay:=SoundBuffer1; + PlayBuffer (CurrentPlay,PlaySampleRate,PlaySampleSize); + If PlayLength >= 16384 then PlaySampleSize:=16384 Else PlaySampleSize:=PlayLength; + Dec (PlayLength,PlaySampleSize); + If CurrentPlay=SoundBuffer1 then + InBuffer (SoundBuffer2^,PlaySampleSize) + Else + InBuffer (SoundBuffer1^,PlaySampleSize); + End + Else Begin + If PlaySampleSize>0 then Begin + If CurrentPlay=SoundBuffer1 then CurrentPlay:=SoundBuffer2 Else CurrentPlay:=SoundBuffer1; + PlayBuffer (CurrentPlay,PlaySampleRate,PlaySampleSize); + PlaySampleSize:=0; + End + Else + PlaybackReady; + End; +End; + +Procedure SoundBlasterPro.WriteDSP (Value : Byte); + +Begin + While Port[WritePort] > 127 Do ; + Port[WritePort]:=Value; +end; + +Function SoundBlasterPro.ReadDSP : Byte; + +Begin + While Port[PollPort] < 128 Do; + ReadDSP:=Port[ReadPort]; +end; + +Procedure SoundBlasterPro.PlayBuffer (Buffer : Pointer; SampleRate : Word; Size : Word); + +Var + SampleRateLimit, Time_constant, Page, Offset : Word; + l : LongInt; + +Begin + + If (Size=0) Or (Size>16384) then Exit; + + Dec (Size); + + { Set up the DMA chip } + {$IFDEF DPMI} + l:=GetSelectorBase (LongInt (Buffer) SHR 16); + {$ELSE} + l:=LongInt (Seg (Buffer^)) SHL 4+Ofs (Buffer^); + {$ENDIF} + Offset:=l MOD 65536; + Page:=l SHR 16; + Port[$0A] := DMAStopMask; + Port[$0C] := 0; + Port[$0B] := DMAModeReg; + Port[$02] := Lo(offset); + Port[$02] := Hi(offset); + Port[$83] := Page; + Port[$03] := Lo(size); + Port[$03] := Hi(size); + Port[$0A] := DMAStartMask; + + { Set the playback SampleRate } + + If InputMode=Stereo then Begin + SampleRateLimit:=11025; + If SampleRate<=SampleRateLimit then Begin + Time_constant := 256 - (1000000 div (2*SampleRate)); + End + Else Begin + Time_constant := Hi (65536-(256000000 DIV (2*SampleRate))); + End; + End + Else Begin + SampleRateLimit:=22050; + If SampleRate<=SampleRateLimit then Begin + Time_constant := 256 - (1000000 div SampleRate); + End + Else Begin + Time_constant := Hi (65536-(256000000 DIV SampleRate)); + End; + End; + WriteDSP ($40); + WriteDSP (Time_constant); + + { Set the playback type (8-bit) } + + If SampleRate<=SampleRateLimit then WriteDSP($14) Else WriteDSP ($48); + WriteDSP (Lo(size)); + WriteDSP (Hi(size)); + If SampleRate>SampleRateLimit then WriteDSP ($91); + + Port [PICPort]:=Port [PICPort] And IrqStartMask; + Port [$20]:=$20; + +End; + +Procedure SoundBlasterPro.RecBuffer (Buffer : Pointer; SampleRate : Word; Size : Word); + +Var + SampleRateLimit, Time_constant, Page, Offset : Word; + l : LongInt; + +Begin + + If (Size=0) Or (Size>16384) then Exit; + + Dec (Size); + + { Set up the DMA chip } + {$IFDEF DPMI} + l:=GetSelectorBase (LongInt (Buffer) SHR 16); + {$ELSE} + l:=LongInt (Seg (Buffer^)) SHL 4+Ofs (Buffer^); + {$ENDIF} + Offset:=l MOD 65536; + Page:=l SHR 16; + Port[$0A] := DMAStopMask; + Port[$0C] := 0; + Port[$0B] := $45; + Port[$02] := Lo (Offset); + Port[$02] := Hi (Offset); + Port[$83] := Page; + Port[$03] := Lo (Size); + Port[$03] := Hi (Size); + Port[$0A] := DMAStartMask; + + { Set the record SampleRate } + If InputMode=Stereo then Begin + SampleRateLimit:=11025; + If SampleRate<=SampleRateLimit then Begin + Time_constant := 256 - (1000000 div (2*SampleRate)); + End + Else Begin + Time_constant := Hi (65536-(256000000 DIV (2*SampleRate))); + End; + End + Else Begin + SampleRateLimit:=22050; + If SampleRate<=SampleRateLimit then Begin + Time_constant := 256 - (1000000 div SampleRate); + End + Else Begin + Time_constant := Hi (65536-(256000000 DIV SampleRate)); + End; + End; + WriteDSP ($40); + WriteDSP (Time_constant); + + { Set the record type (8-bit) } + If SampleRate<=SampleRateLimit then WriteDSP ($24) Else WriteDSP ($48); + WriteDSP (Lo (Size)); + WriteDSP (Hi (Size)); + If SampleRate>SampleRateLimit then WriteDSP ($99); + + Port [PICPort]:=Port [PICPort] And IrqStartMask; + Port [$20]:=$20; + +End; + +Procedure SoundBlasterPro.DisableInterrupts; ASSEMBLER; ASM CLI END; +Procedure SoundBlasterPro.EnableInterrupts; ASSEMBLER; ASM STI END; +Procedure SoundBlasterPro.DisableIrq; + +Begin + Port[PICPort]:=Port[PICPort] Or IrqStopMask; +End; + +Procedure SoundBlasterPro.EnableIrq; + +Begin + Port[PICPort]:=Port[PICPort] And IrqStartMask; +End; + +End. + + + diff --git a/UNITS/FLASH/BUTTON.PAS b/UNITS/FLASH/BUTTON.PAS new file mode 100644 index 0000000..5a85242 --- /dev/null +++ b/UNITS/FLASH/BUTTON.PAS @@ -0,0 +1,165 @@ +Unit button; + +interface + +uses tpstr,types; + +const + cMaxButtons = 32; + cDescSize = 32; + cNoIcon = ''; + cDefWid = 10; + cDefHgt = 10; + cDefColor = 123; + cClickDelay = 100; + cButtonItem = 'button'; + cNoSuchButton = 'Hет такой команды - '; +type + buttonrec = record + x,y,w,h:integer; + desc:String[cDescSize]; + icon:tstring; + run:tstring; + end; + + buttonlist = array[0..cMaxButtons-1] of buttonrec; + + buttondat = record + list:buttonlist; + size:integer; + end; + + procedure unpack_arr(arr:PStringArr; var buttons:buttondat); + function in_buttons(x,y:integer; var buttons:buttondat):boolean; + procedure show_buttons(var buttons:buttondat); + procedure buttons_click(x,y:integer; var buttons:buttondat); + function buttons_desc(x,y:integer; var buttons:buttondat):string; + +implementation + + +uses fx_dev,misc,fx_mouse, + fx_pens,fx_form,tpparam,flashcom, + flobjects,fx_init,flgraph; + + procedure unpack2rec(pack:string; var item:buttonrec); + var dev:pdevice; + begin + with item do begin + x:=toint(get_var('x',pack)); + y:=toint(get_var('y',pack)); + desc:=get_var('desc',pack); + icon:=get_var('icon',pack); + run:=get_var('run',pack); + if icon<>cNoIcon then begin + dev:=New(PDevice,Load(res^.LoadRes(icon)^)); + w:=dev^.Width; + h:=dev^.Height; + Dispose(Dev,Done); + end else begin + w:=cDefWid; h:=cDefHgt; + end; + end; + end; + + procedure show_button(var button:buttonrec); + var p:pcolorpen; + dev:pdevice; + begin + with button do begin + if icon=cNoIcon + then begin + New(p,init(cDefColor)); + Screen^.Rectangle(x,y,x+w-1,y+h-1,p); + Dispose(p,done); + end else begin + dev:=New(PDevice,Load(res^.LoadRes(icon)^)); + dev^.fulldevicecopy(x,y,Screen); + dispose(dev,done); + end; + end; + end; + + function in_button(x,y:integer; var button:buttonrec):boolean; + begin + in_button:= belongs(x,button.x,button.x+button.w-1) and + belongs(y,button.y,button.y+button.h-1); + end; + + procedure click_button(var button:buttonrec); + var p:pCommands; + begin + with button do makeit_glassy(x,y,w,h,cClickDelay); + p:=Player^.Acts^.GetName(button.run); + if p<>nil + then P^.run + else Message(cNoSuchButton+Button.run); + end; + + + procedure unpack_arr(arr:PStringArr; var buttons:buttondat); + var cmd:string; + pack:string; + i:integer; + listsize:integer; + begin + listsize:=0; + for i:=0 to arr^.count-1 do begin + + cmd:=Arr^.Get(i); + pack:=ArgTail(cmd); + cmd:=Argument(Cmd,0); + + if Same(cmd,cButtonItem) then begin + unpack2rec(pack,buttons.list[listsize]); + inc(listsize); + end; + end; + buttons.size:=listsize; + end; + + function in_buttons(x,y:integer; var buttons:buttondat):boolean; + var i:integer; + begin + in_buttons:=false; + for i:=0 to buttons.size-1 do + if in_button(x,y,buttons.list[i]) + then begin + in_buttons:=true; + exit; + end; + end; + + procedure show_buttons(var buttons:buttondat); + var i:integer; + begin + for i:=0 to buttons.size-1 do show_button(buttons.list[i]); + end; + + procedure buttons_click(x,y:integer; var buttons:buttondat); + var i:integer; + begin + for i:=0 to buttons.size-1 do + if in_button(x,y,buttons.list[i]) + then begin + click_button(buttons.list[i]); + exit; + end; + end; + + function buttons_desc(x,y:integer; var buttons:buttondat):string; + var i:integer; + begin + buttons_desc:=''; + for i:=0 to buttons.size-1 do + if in_button(x,y,buttons.list[i]) + then begin + buttons_desc:=buttons.list[i].desc; + exit; + end; + end; + +end. + + + diff --git a/UNITS/FLASH/BUTTONS.PAS b/UNITS/FLASH/BUTTONS.PAS new file mode 100644 index 0000000..8d4925c --- /dev/null +++ b/UNITS/FLASH/BUTTONS.PAS @@ -0,0 +1,62 @@ +Unit Buttons; + +interface + + procedure buttons_init(var f:text); + procedure show_buttons; + function in_buttons(x,y:integer):boolean; + procedure buttons_click(x,y:integer); + function buttons_text(x,y:integer):string; + +implementation + +Uses button,tpstr,fx_file; + + const + cButtonStart = 'ButtonStart'; + cButtonEnd = 'ButtonStop'; + + var buttdat:buttondat; + + procedure buttons_init; + var txt:pStringArr; + begin + txt:=nil; + buttdat.size:=0; + While not eof(f) do + begin + if Same(ReadStrf(f),cButtonStart) + then begin + new(txt,init); + txt^.readto(F,cButtonEnd); + Break; + end; + end; + if txt<>nil then begin + button.unpack_arr(txt,buttdat); + dispose(Txt,Done); + end; +end; + + procedure buttons_click; + begin + button.buttons_click(x,y,buttdat); + end; + + function buttons_text; + begin + buttons_text:=button.buttons_desc(x,y,buttdat); + end; + + procedure show_buttons; + begin + button.show_buttons(buttdat); + end; + + function in_buttons(x,y:integer):boolean; + begin + in_buttons:=button.in_buttons(x,y,buttdat); + end; + + +end. \ No newline at end of file diff --git a/UNITS/FLASH/CONSTANT.PAS b/UNITS/FLASH/CONSTANT.PAS new file mode 100644 index 0000000..475cbb7 --- /dev/null +++ b/UNITS/FLASH/CONSTANT.PAS @@ -0,0 +1,104 @@ +Unit Constants; + +interface + +Const Yes=True; + No=False; + Off=False; + + cProgName='Dreams/DASP'; + cFileName='dreams'; + cDatFile ='.dat'; + cErrFile ='.err'; + cLogFile ='.log'; + cMapFile ='.map'; + cResFile ='.res'; +Type + ShortStr=String[15]; + TCommandProc=Procedure(S:String); + TIfCondition=Function(S:String):Boolean; + TCommandClass=(cPlain,cIf); + + TClassId=(nPlayer,nAtmo,nThing,nLoc,nAct,nHuman); + TDirection=(nNorth,nEast,nSouth,nWest); + +Const + clFirst=nPlayer; + clLast =nHuman; + + cNone ='none'; + cDialog ='Dialog'; + cPlaceDesc ='PlaceDesc'; + cManTalk ='ManTalk'; + cManDesc ='ManDesc'; + cChoice ='Choice'; + cEnd ='end'; + cDialogEnd ='diaend'; + cTime ='time'; + cEvent ='event'; + + CommandClassName:Array[TCommandClass] of String[5]= + ('Plain','If'); + cIfName ='if'; + cThen ='then'; + cElse ='else'; + cEndIf ='end'; + cAnd ='and'; + cOr ='or'; + cFlashComm ='FlashComm'; + cFlashCommEnd ='EndComm'; + cFlashAct ='do'; + cFlashActEnd ='enddo'; + Quiet:Boolean =yes; + + ClassIdName:Array[TClassId] of String[8]= + ('Player','Atmo','Thing','Location','Act','Human'); + + ClassIdNames:Array[TClassId] of String[9]= + ('Player','Atmo','Things','Locations','Acts','Humans'); + + cId:Word =$0000; + cNoResource ='no_resource'; + cNoName ='no_name'; + cNoWhere ='nowhere'; + cNoWay ='no_way'; + cDisposed ='disposed'; + + cClass ='Class'; + cClassEnd ='End'; {ClassEnd} + + cDesc ='text'; + cDescEnd ='end'; + cArea ='area'; + + cThings ='things'; + cThingsEnd ='end'; + + cParams ='params'; + cParamsEnd ='end'; + + cAct ='do'; + cActEnd =cFlashActEnd; + + cSmallAct ='SmallAct'; + cSmallActEnd =cFlashActEnd; + LastId:LongInt =0; + +Function StrToClassId(S:String):TClassId; + +implementation +Uses strconst,tpstr,core; + + +Function StrToClassId(S:String):TClassId; + var t:TClassId; +begin + for t:=low(t) to high(t) do + if Same(s,ClassIdName[t]) then begin + StrToClassId:=t; + exit; + end; + ErrorMsg(StrToChar(cCantConvertID+s)); +end; + +end. diff --git a/UNITS/FLASH/CORE.PAS b/UNITS/FLASH/CORE.PAS new file mode 100644 index 0000000..cd87f78 --- /dev/null +++ b/UNITS/FLASH/CORE.PAS @@ -0,0 +1,274 @@ +Unit Core; +{ Core functions module } +interface + +{$S+,Q+,R+,F+,B+} +const cFATAL_ERR = 1001; + cPLAIN_ERR = 1002; +type + tmessageproc=procedure(message:string); + tchoicey_n =function(message:string):boolean; + tproc =procedure; + +Var PreError:tproc; + +Procedure Halt; +{ if TRUE - stack,heap,ems,xms information will be + printed at exit, else quietly ends program } +procedure SetExitInfo(Val:Boolean); +{ setting handler to call at exit } +Procedure SetCloseHandler(Handler:Pointer); +{ setting methods to input,output - defaults for text mode, + advise: change for graphic mode + must : be changed for unknown SVGA mode } +procedure SetIOmethods(forMESSAGE:TMESSAGEProc; forCHOICE:tChoiceY_n); +procedure DefaultIO; +{ initiates exit - closing program } +procedure initiate_exit; +{ exeption - cant ignore this error } +procedure Exeption(Num:word;Message:Pchar); +{ standart error - prompts for ignore } +procedure Error(Num:word;Message:PChar); +{ same as error, returns number cPLAIN_ERR } +procedure ErrorMSG(Message:PChar); +{ same as exeption, returns number cFATAL_ERR } +procedure FatalMSG(Message:PChar); +{ initiates core error handling } +procedure initiate_core; + +implementation + + uses + swset,strings,streams,tpcrt, + tpstring,plreg; + +const + cHEAP_RUNTIME = 0; + cHEAP_NIL = 1; + cHEAP_OK = 2; + cIGNORE_MESS = 'Press "Y" to ignore, other to continue'; +var + doExitStat:boolean; + CloseHandler:Pointer; + MessageProc:TMessageProc; + ChoiceFunc:TChoiceY_N; + +procedure SetExitInfo; +begin + doExitStat:=Val; +end; +Procedure SetCloseHandler(Handler:Pointer); +begin + CloseHandler:=Handler; +end; +procedure SetIOmethods(forMESSAGE:TMESSAGEProc; forCHOICE:tChoiceY_n); +begin + MessageProc:=forMessage; + ChoiceFunc:=forChoice; +end; + +procedure showStat; +begin + Writeln( 'Program closed.'); + + Writeln( 'Stack: SP=',hexw(SPtr),'h SS=',hexw(SSeg),'h'); + {$IFDEF DPMI} + Writeln( 'Free : ',MemAvail div 1024,' kbytes'); + {$ELSE} + Writeln( 'Heap : Org=',HexPtr(HeapOrg),' Ptr=',HexPtr(HeapPtr), + ' End=',HexPtr(HeapEnd),' Free=',MemAvail:6,' Max=',MaxAvail:6); + Writeln( 'XMS : Free=',XMS_MemAvail:8,' Max=',XMS_MaxAvail:8,' EMS : Free=',EMS_MemAvail:8,' Max=',EMS_MaxAvail:8); + {$ENDIF} +end; + +Procedure Halt; +begin + Initiate_exit; +end; + +procedure initiate_exit; +begin + if assigned(CloseHandler) + then asm + call CloseHandler; + end; + + asm + mov AX,SEG doExitStat + mov ES,AX + mov al,ES:doExitStat + cmp al,0 + je @@SKIPSHOW + call showStat + @@SKIPSHOW: + end; +{ if CloseStandartIO then begin + Close(Input); + Close(Output); + end;} +{ if not DynamicExit then} + asm + mov ax,ExitCode + mov ah,4ch + int 21h + end{ else begin + ExitProc:=Nil; + System.Halt; + end}; +end; + + procedure FatalExit( ErrorNo:word; CS,IP:Word; Message:PChar ); + begin + MessageProc(StrPas(Message)+'(#'+Long2Str(ErrorNo)+') at '+HexW(CS)+':'+HexW(IP)); + ExitCode:=ErrorNo; + ErrorAddr:=Ptr(CS,IP); + initiate_exit; + end; + + procedure ErrorExit( ErrorNo:word; CS,IP:Word; Message:PChar ); + begin + MessageProc(StrPas(Message)+'(#'+Long2Str(ErrorNo)+') at '+HexW(CS)+':'+HexW(IP)); + + If ChoiceFunc(cIGNORE_MESS) + then + begin + asm + pop ax + pop bx + pop dx + pop es + pop di + pop es + pop di + push dx + push bx + end; + ExitCode:=0; + ErrorAddr:=Nil; + end else begin + ExitCode:=ErrorNo; + ErrorAddr:=Ptr(CS,IP); + initiate_exit; + end; + end; + + +procedure Exeption(Num:word;Message:Pchar); +assembler; asm + mov ax,SS:[BP+4] + mov bx,SS:[BP+2] + sub ax,PrefixSeg + sub ax,$10 + + push num + push ax + push bx + les di,Message + push es + push di + + call FatalExit +end; + +procedure Error(Num:word;Message:Pchar); +assembler; asm + mov ax,SS:[BP+4] + mov bx,SS:[BP+2] + sub ax,PrefixSeg + sub ax,$10 + + push num + push ax + push bx + les di,Message + push es + push di + + call ErrorExit +end; + +procedure ErrorMSG(Message:Pchar); +assembler; asm + mov ax,SS:[BP+4] + mov bx,SS:[BP+2] + sub ax,PrefixSeg + sub ax,$10 + + push cPLAIN_ERR + push ax + push bx + les di,Message + push es + push di + + call ErrorExit +end; + +procedure FatalMSG(Message:Pchar); +assembler; asm + mov ax,SS:[BP+4] + mov bx,SS:[BP+2] + sub ax,PrefixSeg + sub ax,$10 + + push cFATAL_ERR + push ax + push bx + les di,Message + push es + push di + + call FatalExit +end; + + + +procedure Core_ExitProc; +begin + if Exitcode<>0 + then FatalExit(ExitCode,Seg(ErrorAddr^),Ofs(ErrorAddr^),find_err_message(ExitCode)) + else initiate_exit; +end; + +procedure default_message(message:string); +begin + if Assigned(PreError) then PreError; + Writeln(Message); + Readkey; +end; + +function default_yes_no(message:string):boolean; +begin + Writeln(message); + default_yes_no:=(UpCase(Readkey)='Y'); +end; + + function HeapHandler(Size:Word):Integer; + begin + if Memavail 35 then + Vendor := 'AMD Am' + else + Vendor := 'Intel '; + else + Vendor := 'Intel '; + end; + end; + +procedure checkUMC; + begin + if _CPU >= i486sxr then + if (CheckP5 and $0F00) = $400 then { Family = 4, don't care of other fields } + if Pos('UMC',GetP5Vendor) <> 0 then + if (GetP5Features and 1) = 1 then + _CPU := umcU5d + else + _CPU := umcU5s; + end; + +function CxStep; + begin + CxStep := Hi(getCyrixModel) shr 4; + end; + +function CxRevision; + begin + CxRevision := Hi(getCyrixModel) and $0F; + end; + +function CxModel : String; + var Id : Word; + isTi : Boolean; + begin + Id := getCyrixModel; + isTi := (Id and $8000) <> 0; { new Ti486DXx have high bit of DIR1 set to 1 } + case Lo(Id) of + 0 : CxModel := 'Cyrix Cx486SLC'; + 1 : CxModel := 'Cyrix Cx486DLC'; + 2 : CxModel := 'Cyrix Cx486SL2'; + 3 : CxModel := 'Cyrix Cx486DL2'; + 4 : CxModel := 'Cyrix Cx486SR'; + 5 : CxModel := 'Cyrix Cx486DR'; + 6 : CxModel := 'Cyrix Cx486SR2'; + 7 : CxModel := 'Cyrix Cx486DR2'; + $10: CxModel := 'Cyrix Cx486S'; + $11: CxModel := 'Cyrix Cx486S2'; + $12: CxModel := 'Cyrix Cx486SE'; + $13: CxModel := 'Cyrix Cx486S2E'; + $1A: begin + FPUType := FPUType and 1 + $10; + if isTi then + CxModel := 'Texas Instruments Ti486DX' + else + CxModel := 'Cyrix Cx486DX'; + end; + $1B: begin + FPUType := FPUType and 1 + $10; + if isTi then + CxModel := 'Texas Instruments Ti486DX2' + else + CxModel := 'Cyrix Cx486DX2'; + end; + $1F: begin + FPUType := FPUType and 1 + $10; + if isTi then + CxModel := 'Texas Instruments Ti486DX4' + else + CxModel := 'Cyrix Cx486DX4'; + end; + $2D, { some sources say M1sc's DIR1=2Dh, some say 29h, so I included both } + $29: begin + CxModel := 'Cyrix M1sc (5x86)'; + FPUType := FPUType and 1 + $10; + end; + $30: begin + CxModel := 'Cyrix M1 (6x86)'; + FPUType := FPUType and 1 + $10; + end; + $FE: CxModel := 'Texas Instruments Ti486SXL (Potomac)'; + else + CxModel := 'Cyrix/Texas Instruments 486'; + end; +end; + +function Am486Model : String; + begin + case CheckP5 and $00F0 of + $0030 : Am486Model := '486DX2'; + $0070 : Am486Model := '486DX2+'; + $0080 : Am486Model := '486DX4'; + $0090 : Am486Model := '486DX4+'; + else + Am486Model := '486'; + end; + end; + +function CPU_TypeStr; + var CPU : Word; +begin + CPU := CPU_Type; + _CPU := CPU; + checkUMC; + if (_CPU = $0A) and (CheckP5 <> 0) then + begin + case CheckP5 and $00F0 of + $0000,$0010 : CPU_TypeStr := 'Intel i486DX'; + $0020 : CPU_TypeStr := 'Intel i486SX'; + $0030 : CPU_TypeStr := 'Intel i486DX2/OverDrive'; + $0040 : CPU_TypeStr := 'Intel i486SL'; + $0050 : CPU_TypeStr := 'Intel i486SX2'; + $0070 : CPU_TypeStr := 'Intel i486DX2WB (P24D)'; + $0080 : CPU_TypeStr := 'Intel i486DX4'; + else + CPU_TypeStr := 'Intel i486??'; + end; + exit; + end; + case CPU of + i88 : CPU_TypeStr := Vendor(CPU)+'8088'; + i86 : CPU_TypeStr := Vendor(CPU)+'8086'; + i188 : CPU_TypeStr := Vendor(CPU)+'80188'; + i186 : CPU_TypeStr := Vendor(CPU)+'80186'; + v20 : CPU_TypeStr := Vendor(CPU)+'V20'; + v30 : CPU_TypeStr := Vendor(CPU)+'V30'; + i286 : CPU_TypeStr := Vendor(CPU)+'80286'; + i386sxr, + i386sxv : CPU_TypeStr := Vendor(CPU)+'386SX'; + i386slr, + i386slv : CPU_TypeStr := Vendor(CPU)+'80386SL'; + i386dxr, + i386dxv : CPU_TypeStr := Vendor(CPU)+'386DX'; + i486sxr, + i486sxv : CPU_TypeStr := Vendor(CPU)+'i486SX'; + i486dxr, + i486dxv : CPU_TypeStr := Vendor(CPU)+'i486DX or i487SX'; + c486slcr, + c486slcv, + c486r, + c486v, + cM1r, + cM1v : CPU_TypeStr := CxModel; + i586r, + i586v : CPU_TypeStr := Vendor(CPU)+'Pentium'; + umcU5sxr, + umcU5sxv : CPU_TypeStr := Vendor(CPU)+'U5-S'; + umcU5dxr, + umcU5dxv : CPU_TypeStr := Vendor(CPU)+'U5-D'; + iP24Tr, + iP24Tv : CPU_TypeStr := Vendor(CPU)+'iP24T (Pentium OverDrive)'; + ibm386r, + ibm386v : CPU_TypeStr := Vendor(CPU)+'386SLC'; + ibm486r, + ibm486v : CPU_TypeStr := Vendor(CPU)+'486SLC'; + ibm486r2, + ibm486v2 : CPU_TypeStr := Vendor(CPU)+'486SLC2'; + ibmBL3r, + ibmBL3v : CPU_TypeStr := Vendor(CPU)+'486BL3 (Blue Lightning)'; + iP54r, + iP54v : CPU_TypeStr := Vendor(CPU)+'iP54C'; + am486dxr, + am486dxv : CPU_TypeStr := Vendor(CPU)+Am486Model; + nx586r, + nx586v : CPU_TypeStr := Vendor(CPU)+'Nx586'; + nx686r, + nx686v : CPU_TypeStr := Vendor(CPU)+'Nx686'; + iP6r, + iP6v : CPU_TypeStr := Vendor(CPU)+'PentiumPro (P6)'; + end; +end; + +function CoPro_TypeStr; + var C : Word; + S : String; + begin + if FPUType = $FF then + begin + C := CPU_Type; + _CPU := C; + checkUMC; + case C of + c486slcr, + c486slcv, + c486r, + c486v : CxModel; + end; + end; + case FPUType of + 0,1 : S := 'Unknown'; + 2 : S := 'None'; + 3 : S := 'Weitek'; + 4 : S := 'Intel 8087'; + 5 : S := 'Intel 8087 and Weitek'; + 6 : S := 'Intel i487sx'; + 7 : S := 'Intel i487sx and Weitek'; + 8 : S := 'Intel 80287'; + 9 : S := 'Intel 80287 and Weitek'; + $A : S := 'Cyrix 82x87'; + $B : S := 'Cyrix 82x87 and Weitek'; + $C : S := 'Intel 80387'; + $D : S := 'Intel 80387 and Weitek'; + $E : S := 'Cyrix 83x87'; + $F : S := 'Cyrix 83x87 and Weitek'; + $10 : S := 'Internal'; + $11 : S := 'Internal and Weitek'; + $12 : S := 'Cyrix 84x87'; + $13 : S := 'Cyrix 84x87 and Weitek'; + $14 : S := 'Intel 80287XL'; + $15 : S := 'Intel 80287XL and Weitek'; + $16 : S := 'IIT 2C87'; + $17 : S := 'IIT 2C87 and Weitek'; + $18 : S := 'IIT 3C87'; + $19 : S := 'IIT 3C87 and Weitek'; + $1A : S := 'ULSI 83x87'; + $1B : S := 'ULSI 83x87 and Weitek'; + $1C : S := 'Cyrix EMC87'; + $1D : S := 'Cyrix EMC87 and Weitek'; + $1E : S := 'C&T 38700'; + $1F : S := 'C&T 38700 and Weitek'; + $20 : S := 'NexGen Nx587'; + $21 : S := 'NexGen Nx587 and Weitek'; + $22 : S := 'IIT 4C87'; + $23 : S := 'IIT 4C87 and Weitek'; + $24 : S := 'NexGen Nx687'; + $25 : S := 'NexGen Nx687 and Weitek'; + else + S := 'Unknown'; + end; + if (C >= i286) and checkEmu then + S := S+', Emulated'; + CoPro_TypeStr := S; + end; + +function CPUSpeed; + var W : Word; + begin + W := Speed(_CPU); + CPUSpeed := ((LongInt(Shift)*CPUFix)/W+5)/10; + end; + +function intCPUSpeed; + var W : Word; + begin + W := Speed(_CPU); + intCPUSpeed := ((LongInt(Shift)*CPUFix) div W + 5) div 10; + end; + +end. diff --git a/UNITS/FLASH/DATA.PAS b/UNITS/FLASH/DATA.PAS new file mode 100644 index 0000000..244032b --- /dev/null +++ b/UNITS/FLASH/DATA.PAS @@ -0,0 +1,51 @@ +unit data; + +interface + +type + tcolors=record + paper, + lightpen, + darkpen, + border:byte; + end; +const + colors:tcolors=( + paper:137; + lightpen:80; + darkpen:77; + border:76); +type + tfont_col=record + curr, + light, + dark:byte; + end; +const + font_col:tfont_col=( + curr:28; + light:80; + dark:46 ); +type + tbutt_cfg=record + delay:word; + leftupper, + rightlower, + border:byte + end; +const + butt_cfg:tbutt_cfg=( + delay:50; + leftupper:78; + rightlower:72; + border:0 ); + +const + cmenufr_size=3; + cmenuc:array[0..cmenufr_size-1] of byte= + (76,78,0); + cmenuground=46; + cGOODCOLOR =72; + +implementation +end. diff --git a/UNITS/FLASH/FLACTION.PAS b/UNITS/FLASH/FLACTION.PAS new file mode 100644 index 0000000..a37b768 --- /dev/null +++ b/UNITS/FLASH/FLACTION.PAS @@ -0,0 +1,575 @@ +Unit FlAction; +{$DEFINE NOIOSYS} + +InterFace + + Uses flobjects,types; + + type TGoProc=procedure(Dir:flobjects.TString); + TFindProc=procedure(find:string); + TProc=procedure; + TChooseFunc=function:nstring; +const + cCHOOSE_INFO:string = 'Выбеpите пpедмет'; + cPAR_PREFIX = 'PAR'; + +var Quered:string; + SaveName:string; + InitLoad:boolean; + + Var GoProc:TGOProc; + LookAtProc:TProc; + ExitProcedure:TProc; + ScenSize:Longint; + ShowTaken:TFindProc; + ChooseFunc:TChooseFunc; + CurrentThing:NString; + ShowMenuProc:TProc; + SwitchEditProc:TProc; + +procedure GlobVarReplace(Var CMD:String); +Procedure LocalMacReplace(var Pars:String); +Procedure MakeCommand(Id:Integer; Pars:String); +Function IfCommand(Id:Integer; Pars:String):boolean; + +Implementation + + uses objects,fx_strop,tpparam,tpstr,locview, + tptimeline,flashcom, + constants,streams,tpcomms,core, + fx_mouse,flgraph, + kernel,things,tpdos,play,sounds, + misc,textlib,fx_init,vdialog,fx_cons, + fx_form,flscript,talks,fontedit,strings + {$IFDEF DPMI} ,winapi,appdll; + {$ELSE} ; {$ENDIF} + + +{$I VARS.PAS} +{$I SAVES.PAS} + +procedure comm_save(s:string); + var p:pdosstream; +begin + new(p,init(s,stCREATE)); + player^.save(p^); + atmo^.save(p^); + thinglist^.save(p^); + loclist^.save(p^); + actlist^.save(p^); + humanlist^.save(p^); + dispose(p,done); +end; +procedure comm_load(s:string); +begin + If ExistFile(s) then begin + Load(s); + end else Message('You weren`t save game in this slot'); +end; +procedure comm_newg(s:string); +begin + {$IFDEF NOIOSYS} + Message('Newgame system is in beta-mode now'); + {$ENDIF} +end; + +procedure comm_i2p(s:string); +begin + control_var(argument(s,0)+' '+findin(argument(s,1))^.playname); +end; + +procedure comm_savepr(s:string); +begin + control_var(s+' '+SaveFile(SavePrompt)); +end; +procedure comm_swedit(s:string); +begin + SwitchEditProc; +end; +procedure comm_waitaud(s:string); +begin + WaitSound; +end; +procedure comm_playsnd(s:string); +begin + PlaySound(S); +end; +Procedure comm_shmenu(s:string); +begin + SHowMenuProc; +end; +Procedure comm_diarun(s:string); +begin + freeze_hands; + dodialog(Argument(s,0)); + unfreeze_hands; +end; +procedure Comm_fonted(s:string); +begin + FontEditor; +end; +procedure Comm_listtopics(s:string); +begin + list_topics; +end; + +Procedure LocalMacReplace(var Pars:String); +begin + fx_strop.Replace('CurrentLoc',CurrentLoc^.Name,Pars); + fx_strop.Replace('LastLoc',LastLoc^.Name,Pars); + fx_strop.replace('CurrentThing',CurrentThing,Pars); + fx_strop.Replace('#player',Player^.Name,Pars); + fx_strop.Replace('#atmo',Atmo^.Name,Pars); + + fx_strop.replace('#hour',ToStr(Atmo^.Timeline^.Hour),Pars); + fx_strop.replace('#day',ToStr(Atmo^.TimeLine^.day),Pars); + fx_strop.replace('#month',ToStr(Atmo^.TimeLine^.month),Pars); + fx_strop.replace('#year',ToStr(Atmo^.TimeLine^.year),Pars); + +{ fx_strop.replace('',,Pars);} + + fx_strop.replace('#emsfree',tostr(ems_memavail div 1024),Pars); + fx_strop.replace('#xmsfree',tostr(xms_memavail div 1024),Pars); + fx_strop.replace('#memfree',tostr(memavail div 1024),Pars); + fx_strop.replace('#diskfree',tostr(disk_memavail div 1024),Pars); + fx_strop.replace('#diskfree',tostr(disk_memavail div 1024),Pars); + + fx_strop.replace('#idrecord',Switches.idrecord,Pars); + fx_strop.replace('#copyright',Switches.copyright,Pars); + fx_strop.replace('#year',Switches.year,Pars); + fx_strop.replace('#version',Switches.version,Pars); + fx_strop.replace('#minorver',Switches.minorversion,Pars); + {$IFDEF DPMI} + fx_strop.replace('#apptype','dpmi',Pars); + {$ELSE} + fx_strop.replace('#apptype','real',Pars); + {$ENDIF} + fx_strop.replace('#scenario',TOStr(ScenSize),Pars); + + fx_strop.Replace('#query',Quered,Pars); + GlobVarReplace(Pars); +end; + +Procedure comm_Beep(s:string); +begin + Writeline('BEEP'); +end; +Procedure comm_Message(s:string); +begin + Writeline(s); +end; +procedure comm_showit(s:string); +begin + show_text; +end; +Procedure comm_Pause(s:String); +begin + anyclick; +end; +Procedure comm_go(s:string); +begin + if LocList^.Find(s)<>nil + then GoProc(s) + else begin + Message('Can`t go there - location not exist'); + updatelocation(currentloc); + end; +end; + +Procedure comm_console(s:string); +begin + Show_console; +end; + +Procedure comm_die(s:string); +begin + LastLoc:=CurrentLoc; + CurrentLoc:=PLocation(LocList^.Find('Void')); + If Not Assigned(CurrentLoc) then FatalMSG('Can`t find void location'); + Player^.Place:='Void'; + UpdateLocation(CurrentLoc); +end; +procedure comm_topic(s:string); +begin + printtopic(s); +end; +Procedure comm_field(s:string); + var name:string; + field:string; + value:string; + obj:Pointer; +begin + Name:=Argument(s,0); + Field:=Argument(s,1); + Value:=Copy(s,Pos(Field,s)+Length(Field)+1,255); + + Obj:=FindIn(Name); + if Assigned(Obj) then PFlashObject(Obj)^.chField(Field,Value) + else Message('Can`t find object '+Name); +end; +procedure comm_year(s:String); +begin + Atmo^.TimeLine^.Year:=ToWord(s); +end; +Procedure comm_month(s:string); +begin + Atmo^.TimeLine^.Month:=ToWord(S); +end; +Procedure Comm_Day(S:string); +begin + Atmo^.TimeLine^.Day:=ToWord(S); +end; +Procedure Comm_Hour(S:string); +begin + Atmo^.TimeLine^.Hour:=ToWord(S); +end; +Procedure comm_showtime(s:string); +begin + Message(Atmo^.TimeLine^.ShowTime); +end; +Procedure comm_hinc(s:string); +begin + Atmo^.TimeLine^.IncHour(1); +end; +Procedure comm_dinc(s:string); +begin + Atmo^.TimeLine^.IncTime(0,0,1,0); +end; +Procedure comm_currevent(s:string); + var i:integer; +begin + Writeline('Current underway events'); + for i:=0 to Atmo^.Timeline^.Count-1 do + if Atmo^.TimeLine^.CheckEvent(Atmo^.TimeLine^.Get(i)^.Event) + then Writeline(Atmo^.TimeLine^.Get(i)^.Event); + Show_text; +end; +Procedure comm_offevent(s:string); + var p:PTimeUnit; +begin + P:=Atmo^.TimeLine^.SearchEvent(s); + if Not Assigned(P) + then ErrorMSG(Str2Pchar('Cannot be found event to turn off:'+s)) + else P^.Year:=1; +end; +Procedure comm_query(s:string); +begin + Quered:=Receive(S); +end; +Procedure comm_mem(s:string); +begin + Message('Free memory on-host available: '+TOSTR(MemAvail div 1024)+' Kbytes') +end; +Procedure comm_look(s:string); +begin + LookAtProc; +end; +Procedure comm_resstr(s:string); + var p:PFlashObject; +begin + p:=findin(s); + if p=nil then quered:='no such object' + else quered:=p^.reskey; +end; +procedure comm_act(s:string); + var name:string; + value:string; + + obj:PAct; +begin + Name:=Argument(s,0); + Value:=Copy(s,Pos(Name,s)+Length(Name)+1,255); + obj:=PAct(ActList^.Find(Name)); + obj^.run(Value); +end; +procedure comm_choice(s:string); + var butt:pbutton_line; + a,b,i:integer; +begin + a:=arguments(s); if (a mod 2) <> 0 + then Message('Incorrect number of args in choice') + else begin + a:=a div 2; + if a>10 then a:=10; + new(butt,init(a,menumaxlen,argument(s,0))); + for b:=0 to a-1 do butt^.add_butt(argument(s,b*2+1)); + hide_mouse; + butt^.center; + show_mouse; + while true do + if mousebuttons<>0 then begin + i:=butt^.pressed(mouseposx,mouseposy); + if i<>-1 then begin + playSound(sndClick); + quered:=argument(s,i*2+2); + break; + end; + while mousebuttons<>0 do; + end; + while mousebuttons<>0 do; + hide_mouse; + dispose(butt,done); + show_mouse; + end; + while mousebuttons<>0 do; +end; +procedure comm_newname(s:string); + var name:string; +begin + if Argument(s,0)<>'' then name:=Argument(s,0) else + begin + name:=Receive('Your name?>'); + end; + Player^.Name:=name; Player^.PlayName:=Name; +end; +procedure comm_exit(s:string); +begin + ExitProcedure; +end; +procedure comm_log(s:string); + var f:text; +begin + loggy(cFILENAME,S) +end; +procedure comm_move(s:string); + var name:string; + tipe:tclassid; + Kind:pFlashObject; + par:string; +begin + tipe:=strToClassId(argument(s,0)); + name:=argument(s,1); + par:=argument(s,2); + Kind:=findin(name); + if Kind=nil then FatalMSG(Str2Pchar('cant find in move:'+s)); + case tipe of + nPlayer : quered:=PPLayer(Kind)^.params^.value(par); + nAtmo : quered:=PATmo(Kind)^.params^.value(par); + nLoc : quered:=PLocation(Kind)^.params^.value(par); + nThing : quered:=PThing(Kind)^.params^.value(par); + nHuman : quered:=PHuman(Kind)^.params^.value(par); + end; +end; + +procedure comm_pick(s:string); + var res:string; + name:string; + value:string; +begin + Name:=Argument(s,0); + Value:=Copy(s,Pos(Name,s)+Length(Name)+1,255); + if Value<>'' then cCHOOSE_INFO:=Value; + + Res:=ChooseFunc; + + if res<>'' then begin + + if Same(Name,'Query') + then Quered:=res + else control_var(Name+' '+Res); + + end else Quered:='VOID'; +end; + +procedure comm_hide(s:string); +begin + hide_find(s,loc_id,screen); + showtaken(s); +end; + +procedure comm_toplayer(s:string); +begin + showtaken(s); +end; +procedure comm_dllrun(s:string); + {$IFNDEF DPMI} + begin + ErrorMSG('Can`t run dll from not a DPMI app'); + end; + {$ELSE} + var index:integer; +begin + index:=ToInt(S); + If Not Belongs(Index,1,10) + then Message('Only external functions with indexes 1..10 are allowed') + else AppDll.CallExternal(Index); +end; + {$ENDIF} + +Procedure MakeCommand; + var Comm:PCommands; + i:integer; +begin + LocalMacReplace(Pars); + if Id=-1 then ErrorMSG('Can`t run act(-1)'); + Comm:=Player^.Acts^.GetName(ActName[Id]); + if Comm<>nil then begin + for i:=0 to Arguments(Pars) do + control_var(cPAR_PREFIX+tostr(i)+' '+Argument(Pars,i)); + LocalMacReplace(Pars); + Comm^.Run; + end else MakeComm(Id,Pars); +end; + +Function cond_debug(s:string):boolean; +begin + cond_debug:=true; +end; +Function cond_event(s:string):boolean; +begin + cond_event:=Atmo^.Timeline^.checkevent(Argument(S,0)); +end; +function cond_equal(s:string):boolean; +begin + cond_equal:=Same(argument(s,0),argument(s,1)); +end; +function cond_check(s:string):boolean; + var s1:string; + p:pFlashCommon; +begin + cond_check:=false; + p:=PFlashCommon(findin(argument(s,0))); + if p<>nil then + begin + if P^.acts^.getname(argument(s,1))<>nil + then cond_check:=true; + end; +end; +Function cond_field(s:string):boolean; + var name:string; + field:string; + value:string; + obj:Pointer; +begin + Name:=Argument(s,0); + Field:=Argument(s,1); + Value:=Copy(s,Pos(Field,s)+Length(Field)+1,255); + + obj:=FindIn(Name); + if Obj=nil then ErrorMSG(Str2PChar('Cant find '+Name)); + cond_field:=PFlashObject(Obj)^.ifField(Field,Value); +end; +Function cond_here(s:string):boolean; +begin + cond_here:=CurrentLoc^.Things^.Search(s)<>-1; +end; +Function cond_place(s:string):boolean; +begin + cond_place:=Same(CurrentLoc^.Name,s) +end; +Function cond_quer(s:string):boolean; +begin + cond_quer:=same(s,quered); +end; +function cond_real(s:string):boolean; +begin + {$IFDEF DPMI} + cond_real:=false; + {$ELSE} + cond_real:=true; + {$ENDIF} +end; +function cond_dpmi(s:string):boolean; +begin + {$IFDEF DPMI} + cond_dpmi:=true; + {$ELSE} + cond_dpmi:=false; + {$ENDIF} +end; +Function IfCommand; + var Name,Params:string; + +begin + if Pars[1]='~' + then IfCommand:=Not IfCommand(Id,Copy(Pars,2,255)) + else begin + LocalMacReplace(Pars); + IfCommand:=MakeCond(Id,Pars); + end; +end; + +procedure comm_rething(s:string); +begin + refresh_thinger; +end; + +{$I acttalk.pas} + +begin + init_globvars; + AppendComm('beep',comm_Beep); + AppendComm('message',comm_Message); + AppendComm('pause',comm_pause); + AppendComm('go',comm_go); + AppendComm('field',comm_field); + AppendComm('year',comm_year); + AppendComm('month',comm_month); + AppendComm('day',comm_day); + AppendComm('hour',comm_hour); + AppendComm('showtime',comm_showtime); + AppendComm('hourinc',comm_hinc); + AppendComm('dayinc',comm_dinc); + AppendComm('currevents',comm_currevent); + AppendComm('offevent',comm_offevent); + AppendComm('die',comm_die); + AppendComm('query',comm_query); + AppendComm('freemem',comm_mem); + AppendComm('look',comm_look); + AppendComm('changename',comm_newname); + AppendComm('showtopic',comm_topic); + AppendComm('runact',comm_act); + AppendComm('choice',comm_choice); + AppendComm('transfer',comm_move); { transfer TOM time } + AppendComm('exit',comm_exit); + AppendComm('logstring',comm_log); + AppendComm('showit',comm_showit); + AppendComm('stackres',comm_resstr); + AppendComm('takeobj',comm_hide); + AppendComm('freshthings',comm_rething); + Regist_TALK; + { New Commands } + { Пpосит пользователя выбpать пpедмет } + { пеpвый паpаметp - пеpеменная или QUERY } + AppendComm('pickthing',comm_pick); + { Кладет вещь в меню вещей игpока } + { Hе пеpемещает ее } + AppendComm('taketoplayer',comm_toplayer); + { Упpавление пеpеменными } + { Var Size 10 } + { Message $SIZE } + { Выводит "10" } + AppendComm('var',control_var); + { Запpашивает пpомпт файла } + AppendComm('fileprompt',comm_savepr); + AppendComm('savegame',comm_save); + AppendComm('loadgame',comm_load); + AppendComm('newgame',comm_newg); + { Показывает меню игpока } + AppendComm('showmenu',comm_shmenu); + { Выводит yказанный диалог на экpан } + { Сохpаняет pезyльтат диалога в QUERY } + AppendComm('dialog',comm_diarun); + { Выводит диалог изменения yстановок } + AppendComm('switchedit',comm_swedit); + AppendComm('fontedit',comm_fonted); + { Runs dll with specified function - index } + AppendComm('dllrun',comm_dllrun); + AppendComm('waitaud',comm_waitaud); + AppendComm('audio',comm_playsnd); + AppendComm('console',comm_console); + AppendComm('topics',comm_listtopics); + AppendComm('id2play',comm_i2p); + + AppendIf('field',cond_field); + AppendIf('debug',cond_debug); + AppendIf('here',cond_here); + AppendIf('place',cond_place); + AppendIf('event',cond_event); + AppendIf('entered',cond_quer); + AppendIF('equal',cond_equal); + AppendIF('check',cond_check); + AppendIF('isreal',cond_real); + AppendIF('isdpmi',cond_dpmi); +end. +{ field objname value } diff --git a/UNITS/FLASH/FLCOMM.PAS b/UNITS/FLASH/FLCOMM.PAS new file mode 100644 index 0000000..5f3d248 --- /dev/null +++ b/UNITS/FLASH/FLCOMM.PAS @@ -0,0 +1,290 @@ +{Unit FlComm;} + + Uses Crt,Objects,TpStr,Constants,misc,fx_strop,tpcomms; + + function RestString(Str:String):String; + begin + RestString:=Copy(Str,Pos(' ',Str)+1,255); + end; + +const cMaxEval = 16; +type TCommandProc = procedure(Cmd:Integer; Pars:string); + TIfCondition = function(Cmd:Integer; Pars:string):boolean; + TCompileError = procedure(Msg:string); +Var FlashMake:TCommandProc; + FlashCond:TIfCondition; + FlashErr :TCompileError; + FlashLine:string; + FlashNum :word; + +type TTokenType = (tokUnknown,tokRun,tokEval,tokIf); + TEvalOp = (evalAnd,evalOr); +type PFlashItem = ^TFlashItem; + TFlashItem = object(TObject) + procedure Run; virtual; + procedure Compile(Var Source:TStringArr; Var Index:Integer); virtual; + function TokenType(AToken:string):TTokenType; virtual; + end; + + PCommand = ^TCommand; + TCommand = object(TFlashItem) + Command : Integer; + Pars : PString; + procedure Run; virtual; + function Evaluate:boolean; + procedure Compile(Var Source:TStringArr; Var Index:Integer); virtual; + destructor Done; virtual; + end; + + PEvaluate = ^TEvaluate; + TEvaluate = object(TFlashItem) + Evaluates : array[0..cMaxEval-1] of PCommand; + EvaluateI : integer; + EvalOp : TEvalOp; + function Evaluate:boolean; + procedure Compile(Var Source:TStringArr; var Index:integer); virtual; + destructor done; virtual; + end; + + PCommands = ^TCommands; + TCommands = object(TFlashItem) + Commands : PCollection; + Name : PString; + constructor Init; + destructor done; virtual; + procedure Run; virtual; + procedure Compile(var Source:TStringArr; var Index:integer); virtual; + end; + + PCondition = ^TCondition; + TCondition = object(TFlashItem) + Evaluate : PEvaluate; + ThenDo,ElseDo : PCommands; + constructor Init; + destructor done; virtual; + procedure Run; virtual; + procedure Compile(var Source:TStringArr; var Index:integer); virtual; + end; + +function TokenType(AToken:String):TTokenType; + begin + if Same(Argument(AToken,0),cIfName) + then TokenType:=tokIf + else if FindComm(Argument(AToken,0))<>-1 + then TokenType:=tokRun + else if FindCond(Argument(AToken,0))<>-1 + then TokenType:=tokEval + else TokenType:=tokUnknown; + end; + +function CreateNextToken(Token:String):PFlashItem; + {$IFNDEF DELPHI} + var result:PFlashItem; + {$ENDIF} +begin + Case TokenType(Token) of + tokUnknown : result:=nil; + tokRun : result:=new(PCommands,init); + tokEval : result:=new(PEvaluate,init); + tokIf : result:=new(PCondition,init); + end; + {$IFNDEF DELPHI} + CreateNextToken:=Result; + {$ENDIF} +end; + procedure TCondition.run; + begin + if Evaluate^.Evaluate + then ThenDo^.Run + else ElseDo^.Run; + end; + procedure TCondition.compile; + var s:string; + begin + s:=Source.get(index); + if Same(argument(s,1),'and') + then Evaluate^.EvalOp:=evalAND + else if Same(argument(s,1),'or') + then Evaluate^.EvalOp:=evalOR + else FlashErr('Can`t understand eval op:'+s); + Evaluate^.Compile(Source,Index); + ThenDo^.Compile(Source,Index); + If not Same(Source.get(Index),cEND) + then ElseDo^.Compile(Source,Index); + end; + constructor TCondition.Init; + begin + inherited init; + new(Evaluate,init); + new(Thendo,init); + new(Elsedo,init); + end; + destructor TCondition.done; + begin + Dispose(Evaluate,done); + Dispose(ThenDo,done); + dispose(Elsedo,done); + end; + procedure TCommands.run; + var a:integer; + begin + for a:=0 to Commands^.Count-1 do PFlashItem(Commands^.At(A))^.Run; + end; + procedure TCommands.compile; + var curr:PFlashItem; + begin + while (not Same(Source.get(Index),cFlashCommEnd)) and + (not Same(Source.get(Index),cEnd)) and + (not Same(Source.get(Index),cElse)) do begin + FlashLine:=Source.get(index); + Inc(FlashNum); + Curr:=CreateNextToken(Source.get(Index)); + if Curr=nil + then FlashErr('Can`t compile next line into commands') + else begin + Curr^.Compile(Source,Index); + Commands^.Insert(Curr); + end; + end; + end; + destructor TCommand.Done; + begin + DisposeStr(Pars); + inherited done; + end; + destructor TEvaluate.done; + var a:integer; + begin + for a:=0 to EvaluateI-1 do Dispose(Evaluates[a],Done); + inherited Done; + end; + constructor TCommands.Init; + begin + inherited init; + New(Commands,Init(5,5)); + Name:=Nil; + end; + destructor TCommands.done; + begin + Dispose(Commands,done); + inherited done; + end; + + procedure TEvaluate.Compile; + begin + While Not Same(Source.Get(Index),cThen) do begin + New(Evaluates[EvaluateI],Init); + Evaluates[EvaluateI]^.Compile(Source,Index); + Inc(EvaluateI); + if EvaluateI=16 + then begin + FlashErr('Too mush conditions'); + Exit; + end; + end; + end; + function TEvaluate.Evaluate; + {$IFNDEF DELPHI} + var result:boolean; + {$ENDIF} + var a:integer; + begin + case EvalOp of + evalAND : result:=true; + evalOr : result:=false; + end; + for a:=0 to EvaluateI-1 do + case EvalOp of + evalAND : begin + result:=result and Evaluates[a]^.Evaluate; + if result=false then break; + end; + evalOR : begin + result:=result or Evaluates[a]^.Evaluate; + if result=true then break; + end; + end; + {$IFNDEF DELPHI} + Evaluate:=result; + {$ENDIF} + end; + + procedure TCommand.Run; + begin + FlashMake(Command,Pars^); + end; + procedure TCommand.Compile; + var S:String; + begin + S:=Source.Get(Index); + Command:=FindComm(Argument(S,0)); + if Command=-1 then Command:=FindCond(Argument(S,0)); + if Command=-1 then FlashErr('Can`t find Comm or Cond Id for :'+Argument(S,0)); + Pars:=NewStr(RestString(S)); + Inc(Index); + FlashLine:=Source.Get(index); + Inc(FlashNum); + end; + function TCommand.Evaluate; + begin + Evaluate:=FlashCond(Command,Pars^); + end; + + procedure TFlashItem.Run; + begin + Abstract; + end; + procedure TFlashItem.Compile; + begin + Abstract; + end; + function TFlashItem.TokenType; + begin + if Same(Argument(AToken,0),cIfName) + then TokenType:=tokIf + else if FindComm(Argument(AToken,0))<>-1 + then TokenType:=tokRun + else if FindCond(Argument(AToken,0))<>-1 + then TokenType:=tokEval + else TokenType:=tokUnknown; + end; + + procedure DummyRun(Command:integer; pars:string); + begin + Writeln('Runid',Command,'pars :'+Pars); + end; + function DummyIf(Command:integer; pars:string):boolean; + begin + Writeln('Ifid ',Command,' pars :'+Pars); + DummyIf:=Readkey='1'; + end; + procedure Error(Msg:string); + begin + Writeln('Error :'+Msg); + Writeln('Line(',FlashNum,')'+FlashLine); + Halt; + end; + + var p:PStringArr; + f:text; + c:PCommands; + i:integer; +begin + FlashMake:=DummyRun; + FlashCond:=DummyIf; + FlashErr:=Error; + + FlashNum:=1; + New(P,init); + assign(f,'1.txt'); + reset(f); + P^.ReadCount(f,-1); + New(C,init); + i:=1; + c^.compile(P^,i); + c^.run; + Dispose(C,done); + Dispose(P,done); + close(f); +end. + diff --git a/UNITS/FLASH/FLGRAPH.PAS b/UNITS/FLASH/FLGRAPH.PAS new file mode 100644 index 0000000..ebd2e3c --- /dev/null +++ b/UNITS/FLASH/FLGRAPH.PAS @@ -0,0 +1,373 @@ +Unit flGraph; + +interface + +Uses tpstr,fx_form,objects,types,fx_dev; + +var + menu_dev,about_dev,wize_dev:word; + +const + cView :viewrec=( + x: 0; y: 0; w:259; h:174 ); + + cStatus :viewrec=( + x: 0; y:160; w:260; h:10 ); + + cMenu :viewrec=( + x:260; y: 0; w: 60; h:200 ); + + cDreams :viewrec=( + x:265; y: 5; w: 50; h: 15 ); + cWizecore :viewrec=( + x:264; y:183; w: 53; h: 14 ); + + const + locwinx =0; + locwiny =0; + locwidth =259; + locheight =174; + + sidex =260; + sidey =0; + sidewidth =60; + sideheight=200; + + menux =sidex+2; + menuy =sidey+87; + menumaxlen=110; + + aboutx =275; + abouty =5; + aboutw =40; + abouth =20; + +const + cCHOOSE_PICKTHING = 'Вы должны выбpать пpедмет'; + +const + colorx=260; + colory=185; + colorw=50; + colorh=20; + + color:trect=( + a:(x:colorx;y:colory); + b:(x:colorx+colorw-1; y:colorx+colorh-1)); + + locrect:trect=( + a:(x:locwinx; y:locwiny); + b:(x:locwinx+locwidth-1; y:locwiny+locheight-1)); + + about:trect=( + a:(x:aboutx; y:abouty); + b:(x:aboutx+aboutw-1; y:abouty+abouth-1)); + + function ChooseThing:nstring; + procedure dshow_em(c:byte; dev:pdevice); + procedure makeit_glassy(x,y,w,h:integer; delay:integer); + + procedure init_main; + procedure done_main; + procedure clip; + procedure clipoff; + procedure aboutmenu; + procedure wizemenu; + function MessageWindow(p:PstringArr):Boolean; + function messWinXY(x,y:word; p:PstringArr):ptextwindow; + function show_arr(x,y:integer; title:nstring; text:pstringarr):integer; + + procedure putline_text(s:string); + function show_text:Boolean; + procedure message(s:string); + procedure writeline(s:string); + function receive(s:string):string; + procedure end_text; + +implementation + +Uses data,kernel,core,streams,things,status, + fx_mouse,fx_pens,fx_types,flscript,flaction, + fx_fonts,fx_pal,res_type,fx_shape,constants, + sysinfo,time,fx_init,imgstack,flobjects, + locview,play,sounds,fx_cons; + + procedure makeit_glassy(x,y,w,h:integer; delay:integer); + var glass:pconvertpen; + begin + new(glass,init(Palette^.glassindex)); + click_it(x,y,w,h,glass,delay,screen); + dispose(glass,done); + end; + + function show_arr(x,y:integer; title:types.nstring; text:pstringarr):integer; + var buttons:pbutton_line; + visible:byte; + tsize,size:word; + a,pressed:integer; + begin + if text^.count<=5 then visible:=text^.count else visible:=5; + size:=LightFont^.lnWidth(title); + + for a:=0 to text^.count-1 do begin + tsize:=lightfont^.lnWidth(text^.get(a)); + if tsize>size then size:=tsize; + end; + + size:=size+22; + + new(buttons,init(visible,size,title)); + for a:=0 to text^.count-1 do buttons^.add_butt(text^.get(a)); + hide_mouse; + buttons^.show(x,y); + show_mouse; + pressed:=-1; + while pressed=-1 do + if mousebuttons<>0 + then pressed:=buttons^.pressed(mouseposx,mouseposy); + + show_arr:=pressed; + hide_mouse; + dispose(buttons,done); + show_mouse; + end; + +function receive; + var edit:pedit_line; +begin + new(edit,init(s,200)); + receive:=edit^.edit; + dispose(edit,done); +end; + +procedure writeline; +begin + putline_text(s); +end; + + var clipbuff:pointer; + bufftext:pstringarr; + + procedure end_text; + begin + if bufftext<>nil then dispose(bufftext,done); +{ new(bufftext,init);} + bufftext:=nil; + end; + + procedure clip; + begin + getmem(clipbuff,320*200); + move(Screen^.start^,clipbuff^,320*200); + end; + procedure clipoff; + begin + move(clipbuff^,screen^.start^,320*200); + freemem(clipbuff,320*200); + end; + + procedure init_main; + var c:pcolorpen; + begin +{ echo_of_dreams:=loaddev('ECHOPIC');} + menu_dev:=loaddev('MAINMENU'); + about_dev:=loaddev('ABOUTTEXT'); + wize_dev:=loaddev('WIZETEXT'); + +{ press_snd.load(res^.loadres('PRESS_SND')^); + scroll_snd.load(res^.loadres('PRESS_SND')^); + open_snd.load(res^.loadres('OPEN_SND')^); + close_snd.load(res^.loadres('CLOSE_SND')^);} + + end; + procedure done_main; + begin + end; + + procedure aboutmenu; + begin + PlaySound(sndOpenWin); + hide_mouse; + clip; + images^.center(about_dev,screen); + show_mouse; + anyclick; + hide_mouse; + clipoff; + show_mouse; + PlaySound(sndCloseWin); + end; + + procedure wizemenu; + begin + PlaySound(sndOpenWin); + hide_mouse; + clip; + images^.center(wize_dev,screen); + show_mouse; + anyclick; + hide_mouse; + clipoff; + show_mouse; + PlaySound(sndCloseWin); + end; + + + function MessageWindow(p:PstringArr):boolean; + var twin:ptextwindow; + a:integer; + s:string; + fr:{parr_frame}pframe; + size,tsize:word; + begin + if (not assigned(p)) or (p^.count=0) then exit; + s:=p^.get(p^.maxlennum); + size:=0; for a:=0 to p^.count-1 do begin + tsize:=lightfont^.lnWidth(p^.get(a)); + if tsize>size then size:=tsize; + end; size:=size+3; +{ fr:=new(parr_frame,init); + for a:=0 to cmenufr_size-1 do fr^.put(new(pcolorpen,init(cmenuc[a])),yes); +} + fr:=rnd_fr; + new(twin, + init( p^.count,size, + make_form( + fr, + new(pconvertpen,init(Palette^.GlassIndex)), + lightfont),screen)); + + for a:=0 to p^.count-1 do twin^.put(p^.get(a)); + PlaySound(sndOpenWIn); + hide_mouse; + twin^.center; + show_mouse; + MessageWindow:=anyclick; + PlaySound(sndCloseWin); + hide_mouse; + dispose(twin,done); + show_mouse; + end; + + function messWinXY(x,y:word; p:PstringArr):ptextwindow; + var twin:ptextwindow; + a:integer; + s:string; + fr:{parr_frame}pframe; + size,tsize:word; + begin + if (not assigned(p)) or (p^.count=0) then exit; + size:=0; for a:=0 to p^.count-1 do begin + tsize:=lightfont^.lnWidth(p^.get(a)); + if tsize>size then size:=tsize; + end; size:=size+3; +{ fr:=new(parr_frame,init); + for a:=0 to cmenufr_size-1 do fr^.put(new(pcolorpen,init(cmenuc[a])),yes);} + fr:=Good_fr; + new(twin, + init( p^.count,size, + make_form( + fr, + new(pcolorpen,init(cmenuground)), + lightfont),screen)); + + for a:=0 to p^.count-1 do twin^.put(p^.get(a)); + PlaySound(sndOpenWin); + hide_mouse; + twin^.show(x,y); + show_mouse; + messWinXY:=twin; + end; + + procedure putline_text(s:string); + begin + if bufftext=nil then new(bufftext,init); + bufftext^.put(s); + end; + function show_text; + begin + if bufftext=nil then exit; + Show_Text:=MessageWindow(bufftext); + dispose(bufftext,done); + bufftext:=nil; + end; + procedure message(s:string); + begin + putline_text(s); + show_text; + end; + +function ChooseThing:types.nstring; + var + Choosed:Boolean; + x,y:integer; + s,s1:nstring; + Kind:pFlashObject; + pnt:TPoint; + {$IFNDEF DELPHI} + Var Result:NString; + {$ENDIF} +begin + Choosed:=false; + While not choosed do begin + + if (mouseposx<>x) or (mouseposy<>y) + then begin + x:=mouseposx; y:=mouseposy; + pnt.x:=x; pnt.y:=y; + if locrect.contains(pnt) + then begin + s:=get_name(x,y,loc_id); + s1:=get_find(x,y,loc_id); + if FindIn(s1)^.Kind<>nThing then s:=cCHOOSE_INFO; + end else if in_thingbar(x,y) + then begin + s1:=name_thingbar(x,y); + Kind:=findin(s1); + if Kind=nil + then s:=cCHOOSE_INFO + else s:=Kind^.PlayName; + end else s:=cCHOOSE_INFO; + + if (s=CURRENTLOC^.PlayNAME) or (s='') then s:=cCHOOSE_INFO; + + if s=cCHOOSE_INFO + then string2status(s) + else string2status(cCHOOSE_INFO+' - '+s); + end; + + if (mousebuttons<>0) + then begin + + if MouseButtons=02 then begin + Result:=''; + Break; + end; + + Kind:=FindIn(s1); + if (Kind<>nil) and (Kind^.Kind<>nLoc) + then begin + Result:=s1; + Choosed:=true + end else begin + ClearInput; + Message(cCHOOSE_PICKTHING); + end; + + end; + + end; + clearinput; + ChooseThing:=Result; +end; + +procedure dshow_em(c:byte; dev:pdevice); +begin + cview.show(c,dev); + cstatus.show(c,dev); + cmenu.show(c,dev); + cdreams.show(c,dev); + cwizecore.show(c,dev); +end; + +end. diff --git a/UNITS/FLASH/FLMAIN.PAS b/UNITS/FLASH/FLMAIN.PAS new file mode 100644 index 0000000..14f06ed --- /dev/null +++ b/UNITS/FLASH/FLMAIN.PAS @@ -0,0 +1,183 @@ +Unit FlMain; + +interface + +Uses kernel,crt,fx_file,misc,core,TPStr, + objects,Constants,TPParam,types, + FlashCom,TPTimeLine,flobjects,flaction, + SysInfo,time,fx_form; + +const + cLoadingPlayer = 'Загpyжается описание Игpока'; + cLoadingAtmo = 'Загpyжается описание Окpyжения'; + cLoadingThing = 'Загpyжается описание энкантеpа - '; + cLoadingLoc = 'Загpyжается описание локации - '; + cLoadingAct = 'Загpyжается описание акта - '; + cLoadingHuman = 'Загpyжается описание человека - '; + cLoadingMain = 'Загpyжается запyскаемая часть'; + +Type + TSwitches=record + IdRecord, + CopyRight, + Year, + Version, + MinorVersion:NString; + end; + +Function NewClass(cName,cPlayName,cResKey:TString;cClass:TClassId):Pointer; +Procedure DoneAll; +Procedure InitFile(Pr:PProcessBar; Var F:Text); +Procedure ConfigureSwitches(Var Switches:TSwitches;Var F:Text); + +implementation +uses swset,tpdos,flgraph,fx_pens,fx_init; + +(* workout procedures *) +Function NewClass(cName,cPlayName,cResKey:TString;cClass:TClassId):Pointer; + var P:Pointer; +begin + case cClass of + nPlayer : P:=New(PPlayer,Init(cName,cPlayName)); + nAtmo : P:=New(PAtmo,Init(cName,cPlayName)); + nThing : P:=New(PThing,Init(cName,cPlayName)); + nLoc : P:=New(PLocation,Init(cName,cPlayName)); + nAct : P:=New(PAct,Init(cName,cPlayName)); + nHuman : P:=New(PHuman,Init(cName,cPlayName)); + end; + PFlashObject(P)^.Kind:=cClass; + PFlashObject(P)^.ResKey:=cResKey; + NewClass:=P; +end; + + +Procedure DoneAll; +begin + Dispose(Player,Done); + Dispose(Atmo,Done); + Dispose(ThingList,Done); + Dispose(LocList,Done); + Dispose(ActList,Done); + Dispose(HumanList,Done); + Dispose(RunPart,Done); +end; + +Const + cLazyMessX = 0; + cLazyMessY = 10; + cLazyMessW = 250; + cLazyMessH = 9; + cLazyMessCol= 145; + +Procedure LazyMessage(S:String); + var p:pcolorpen; +begin + If Not DoItemBar then Exit; + New(P,init(0)); + Screen^.Map( cLazyMessX,cLazyMessY, + cLazyMessX+cLazyMessW-1,cLazyMessY+cLazyMessH-1,P); + P^.SetColor(cLazyMessCol); + LightFont^.Writeln(cLazyMessX,cLazyMessY,Screen,S); + Dispose(P,DOne); +end; + +Procedure InitFile; + Var S:String; + Kind:String; + ClassId:TClassId; + P:Pointer; + i:integer; + + Str:PStringArr; +begin + (* reading player *) + LazyMessage(cLoadingPlayer); + S:=Value(F,ClassIdName[nPlayer]); + Player:=NewClass(Argument(S,0),Argument(S,1),Argument(S,2),nPlayer); + Player^.Compile(F); + (* reading atmo *) + LazyMessage(cLoadingAtmo); + S:=Value(F,ClassIdName[nAtmo]); + Atmo:=NewClass(Argument(S,0),Argument(S,1),Argument(S,2),nAtmo); + Atmo^.Compile(F); + (* init lists *) + New(ThingList,Init(1,3)); + New(LocList,Init(1,3)); + New(ActList,Init(1,3)); + New(HumanList,Init(1,3)); + New(RunPart,Init); + (* reading things,locations,acts and humans *) + (* they can be mixed *) + DirectVideo:=false; + S:=''; i:=0; + S:=ReadStr(F); + While not Eof(F) do + begin + inc(i); + + if DoLogOut then if S<>'' then loggy('dreams',S); + if DoProcessBar then if belongs(TextPos(F) mod 1000,0,100) then Pr^.NextVal(TextPos(F)); + + Kind:=Argument(S,0); + If Same(Kind,ClassIdName[nThing]) + then begin + LazyMessage(cLoadingThing+Argument(S,1)); + P:=NewClass(Argument(S,1),Argument(S,2),Argument(S,3),nThing); + PThing(P)^.Compile(F); + ThingList^.Put(P); + end; + + If Same(Kind,ClassIdName[nLoc]) + then begin + LazyMessage(cLoadingLoc+Argument(S,1)); + P:=NewClass(Argument(S,1),Argument(S,2),Argument(S,3),nLoc); + PLocation(P)^.Compile(F); + LocList^.Put(P); + end; + + If Same(Kind,ClassIdName[nAct]) + then begin + LazyMessage(cLoadingAct+Argument(S,1)); + P:=NewClass(Argument(S,1),Argument(S,2),Argument(S,3),nAct); + PAct(P)^.Compile(F); + ActList^.Put(P); + end; + + If Same(Kind,ClassIdName[nHuman]) + then begin + LazyMessage(cLoadingHuman+Argument(S,1)); + P:=NewClass(Argument(S,1),Argument(S,2),Argument(S,3),nHuman); + PHuman(P)^.Compile(F); + HumanList^.Put(P); + end; + + If Same(Kind,'Main') then begin + LazyMessage(cLoadingMain+Argument(S,1)); + Str:=New(PStringArr,Init); + Str^.ReadTo(F,'Endmain'); + CompileCode(RunPart,Str,'Main'); + Dispose(Str,Done); + end; + + S:=ReadStr(F); + end; + LazyMessage(''); + (* initing of Currentloc and LastLoc *) + CurrentLoc:=Plocation(LocList^.Find(Player^.Place)); + LastLoc:=CurrentLoc; + If CurrentLoc=nil then ErrorMSG('Player place undefined'); +end; + + Procedure ConfigureSwitches(Var Switches:TSwitches;Var F:Text); + begin + Reset(F); + With Switches do begin + IdRecord:=Value(F,'IdRecord'); + CopyRight:=Value(F,'Copyright'); + Year:=Value(F,'Year'); + Version:=Value(F,'Version'); + MinorVersion:=Value(F,'MinorVersion'); + end; + end; + +end. \ No newline at end of file diff --git a/UNITS/FLASH/FLOBJECT.PAS b/UNITS/FLASH/FLOBJECT.PAS new file mode 100644 index 0000000..bb1dc5b --- /dev/null +++ b/UNITS/FLASH/FLOBJECT.PAS @@ -0,0 +1,732 @@ +Unit FlObjects; + +interface + +Uses Objects,TPStr,TpParam,FlashCom, + TpTimeLine,Constants; + +type TString = string[75]; + IdentString = string[16]; { identifier string } + + PIdentifiers = ^TIdentifiers; + TIdentifiers = object(TStringArr) + procedure Change(Ident:IdentString); + { / syntax / + // puts identifier in array + - // deletes ident if exist + -* // deletes all idents + -# // deletes -ident } + end; + +type PFlashObject = ^TFlashObject; + TFlashObject = object(TObject) + { standart data } + Name : IdentString; { identifier } + PlayName : TString; { in-play name } + Reskey : TString; { resources } + Kind : TClassId; + { init/done } + constructor init(AName:IdentString; APlayName:TString); + procedure restore(var S:TStream); virtual; + procedure save(var S:TStream); virtual; + { standart procedures } + procedure chField(Field:IdentString; Value:tstring); virtual; + function ifField(Field:IdentString; Value:tstring):boolean; virtual; + procedure Process(Field:IdentString; Value:tstring; var f:text); virtual; + procedure Compile(Var F:Text); + end; + + PFlashCommon = ^TFlashCommon; + TFlashCommon = object(TFlashObject) + { common data } + Acts : PCommands; + Text : PStringArr; + Params : PParamColl; + { init/done } + constructor init(AName:IdentString; APlayName:TString); + procedure restore(var S:TStream); virtual; + procedure save(var S:TStream); virtual; + destructor done; virtual; + { overrided procedures } + procedure chField(Field:IdentString; Value:tstring); virtual; + function ifField(Field:IdentString; Value:tstring):boolean; virtual; + procedure Process(Field:IdentString; Value:tstring; var f:text); virtual; + end; + + PPlayer = ^TPlayer; + TPlayer = object(TFlashCommon) + Place : IdentString; + Things : PIdentifiers; + { init/done } + constructor init(AName:IdentString; APlayName:TString); + procedure restore(var S:TStream); virtual; + procedure save(var S:TStream); virtual; + destructor done; virtual; + { overrided procedures } + procedure chField(Field:IdentString; Value:tstring); virtual; + function ifField(Field:IdentString; Value:tstring):boolean; virtual; + procedure Process(Field:IdentString; Value:tstring; var f:text); virtual; + end; + + PThing = ^TThing; + TThing = object(TFlashCommon) + Place : IdentString; + procedure restore(var S:TStream); virtual; + procedure save(var S:TStream); virtual; + { overrided procedures } + procedure chField(Field:IdentString; Value:tstring); virtual; + function ifField(Field:IdentString; Value:tstring):boolean; virtual; + procedure Process(Field:IdentString; Value:tstring; var f:text); virtual; + end; + + PLocation = ^TLocation; + TLocation = object(TFlashCommon) + Things : PIdentifiers; + Directions : PStringArr; + { init/done } + constructor init(AName:IdentString; APlayName:TString); + procedure restore(var S:TStream); virtual; + procedure save(var S:TStream); virtual; + destructor done; virtual; + { overrided procedures } + procedure chField(Field:IdentString; Value:tstring); virtual; + function ifField(Field:IdentString; Value:tstring):boolean; virtual; + procedure Process(Field:IdentString; Value:tstring; var f:text); virtual; + end; + + PHuman = ^THuman; + THuman = object(TPlayer) + end; + + PAtmo = ^TAtmo; + TAtmo = object(TFlashObject) + Params : PParamColl; + TimeLine: PTimeLine; + { init/done } + constructor init(AName:IdentString; APlayName:TString); + procedure restore(var S:TStream); virtual; + procedure save(var S:TStream); virtual; + destructor done; virtual; + { overrided procedures } + procedure chField(Field:IdentString; Value:tstring); virtual; + function ifField(Field:IdentString; Value:tstring):boolean; virtual; + procedure Process(Field:IdentString; Value:tstring; var f:text); virtual; + end; + + PAct = ^TAct; + TAct = object(TFlashObject) + Acts : PCommands; + Params : TString; + { init/done } + constructor init(AName:IdentString; APlayName:TString); + procedure restore(var S:TStream); virtual; + procedure save(var S:TStream); virtual; + destructor done; virtual; + { overrided procedures } + procedure chField(Field:IdentString; Value:tstring); virtual; + function ifField(Field:IdentString; Value:tstring):boolean; virtual; + procedure Process(Field:IdentString; Value:tstring; var f:text); virtual; + { other } + procedure Run(cParams:TString); + end; + +Type (* List definition *) + PList=^TList; + TList=object(TCollection) + Procedure Put(Item:PFlashObject); + Function Get(Index:Integer):PFlashObject; + Function Find(cName:TString):PFlashObject; + procedure restore(Var S:TStream); + procedure save(Var S:TStream); + end; +Var + BaseName:String; + (* base parts of program *) + Player:PPlayer; + Atmo:PAtmo; + ThingList, + LocList, + ActList, + HumanList:PList; + CurrentLoc,LastLoc:PLocation; + (* running part *) + RunPart:PCommands; + +Function FindIn(Name:String):PFlashObject; + +implementation + + uses core,misc,flgraph; + + procedure TFlashObject.Restore; + begin + S.Read(Kind,Sizeof(Kind)); + Name:=GetString(S); + PlayName:=GetString(S); + Reskey:=GetString(S); + end; + procedure TFlashObject.Save; + begin + S.Write(Kind,Sizeof(Kind)); + PutString(Name,S); + PutString(PlayName,S); + PutString(Reskey,S); + end; + + procedure TFlashCommon.Restore; + begin + inherited restore(s); +{ new(acts,init); acts^.load(s);} + dispose(text,done); new(text,load(s)); + dispose(params,done); new(params,load(s)); + end; + procedure TFlashCommon.Save; + begin + inherited save(s); + { acts^.store(s); } + text^.store(s); + params^.store(s); + end; + + procedure TPlayer.Restore; + begin + inherited restore(s); + dispose(things,done); new(things,load(s)); + Place:=GetString(S); + end; + procedure TPlayer.Save; + begin + inherited save(s); + things^.store(s); + PutString(Place,S); + end; + + procedure TThing.Restore; + begin + inherited restore(s); + Place:=GetString(S); + end; + procedure TThing.Save; + begin + inherited save(s); + PutString(Place,S); + end; + + procedure TLocation.Restore; + begin + inherited restore(s); + dispose(things,done); new(things,load(s)); + dispose(directions,done); new(directions,load(s)); + end; + procedure TLocation.Save; + begin + inherited save(s); + things^.store(s); + directions^.store(s); + end; + + procedure TAtmo.Restore; + begin + inherited restore(s); + dispose(params,done); new(Params,load(s)); + Timeline^.restore(s); + end; + procedure TAtmo.Save; + begin + inherited save(s); + params^.store(s); + timeline^.save(s); + end; + + procedure TAct.Restore; + begin + inherited restore(s); + Params:=GetString(S); +{ new(Acts,init); acts^.load(s);} + end; + procedure TAct.Save; + begin + inherited save(s); + PutString(Params,S); +{ acts^.store(s);} + end; + +Function FindIn(Name:String):PFlashObject; +var obj:Pointer; +begin + if Same(Player^.Name,Name) + then obj:=Player + else if Same(Atmo^.Name,Name) + then Obj:=Atmo + else if ThingList^.Find(Name)<>Nil + then Obj:=ThingList^.Find(Name) + else if LocList^.Find(Name)<>Nil + then Obj:=LocList^.Find(Name) + else if ActList^.Find(Name)<>Nil + then Obj:=ActList^.Find(Name) + else if HumanList^.Find(Name)<>Nil + then Obj:=HumanList^.Find(Name) + else Obj:=Nil; + FindIn:=Obj; +end; + + Procedure TList.Put; + begin + if Assigned(Item) + then Insert(Item) + else ErrorMSG('Trying to put unassigned object'); + end; + Function TList.Get; + begin + If (Index=0) + then Get:=At(Index) + else ErrorMSG('Index out of range'); + end; + Function TList.Find; + var I:Integer; + begin + For I:=0 to Count-1 do + if Same(Get(I)^.Name,cName) + then begin + Find:=Get(I); + Exit; + end; + Find:=Nil; + end; + procedure TList.save(Var S:TStream); + var a:integer; + begin + a:=Count; + S.Write(a,sizeof(a)); + for a:=0 to Count-1 do + get(a)^.save(s); + end; + function TestKind(Var S:TStream):TClassId; + var c:tclassid; + begin + S.Read(c,sizeof(c)); + S.Seek(S.GetPos-sizeof(c)); + TestKind:=c; + end; + procedure TList.Restore(Var S:TStream); + var a,b:integer; + p:pflashobject; + begin + S.Read(b,sizeof(b)); + for a:=0 to b-1 do begin +{ case TestKind(S) of + nPLAYER : p:=new(PPlayer,Load(S)); + nATMO : p:=new(PAtmo,Load(S)); + nTHING : p:=new(PThing,Load(S)); + nLOC : p:=new(PLocation,Load(S)); + nACT : p:=new(PAct,Load(S)); + nHUMAN : p:=new(PHUMAN,Load(S)); + else p:=nil; + end; + if p<>nil then Insert(p) else ErrorMSG('Read error');} + get(a)^.restore(s); + end; + end; + + procedure TIdentifiers.Change; + begin + if Ident[1]<>'-' + then Put(Ident) + else case Ident[2] of + '*' : Delete(0,Count); + '#' : Delete(ToInt(System.Copy(Ident,3,255)),1); + else Delete(Search(System.Copy(Ident,2,255)),1); + end; + end; + +procedure ChangeCommands(var Comms:PCommands; Value:tstring); + var p:pflashitem; +begin + p:=Comms^.GetName(Value); + if p=nil + then ErrorMsg(Str2PChar('Can`t run specified act '+Value)) + else p^.run; +end; + +procedure ChangePlace(var Place:TString; Value:tstring); +begin + Place:=Value; +end; +procedure ChangeThings(var Things:PIdentifiers; Value:IdentString); +begin + Things^.Change(Value); +end; +procedure ChangeText(var Text:PStringArr; Value:tstring); +begin + Text^.Put(Value); +end; +procedure ChangeParams(var Params:PParamColl; Value:tstring); +begin + Params^.SetValue(Value); +end; +procedure ChangeDirs(var Dirs:PStringArr; Value:TString); + var Act:IdentString; + I:Integer; +begin + Act:=Argument(Value,0); + Value:=RestString(Value); + UpcaseStr(Act); + if act='ADD' then Dirs^.Put(Value) + else if act='DEL' then begin + I:=Dirs^.SearchPart(Value,1); + if I<>-1 + then Dirs^.Delete(I,1) + else ErrorMSG(Str2PChar('Can`t find dirID: '+Value)); + end + else if act='DELALL' then Dirs^.Delete(0,Dirs^.Count); + +end; + +Procedure ReadThings(Things:PIdentifiers; Var F:Text); +begin + Things^.ReadTO(f,cThingsEnd); +end; +Procedure ReadText(Desc:PStringArr; Var F:TExt); +begin + Desc^.ReadTo(F,cDescEnd); +end; +Procedure ReadDirs(Dirs:PStringArr;Var F:Text); +begin + Dirs^.ReadTo(F,'end'); +end; +Procedure ReadParams(Params:PParamColl; var F:text); + var s:TString; +begin + S:=ReadStr(F); + While not(Same(S,cParamsEnd)) do + begin + Params^.SetValue(S); + S:=ReadStr(F); + end; +end; +Procedure ReadActs(Name:string; Acts:PCommands;Var F:Text); +var P:PStringArr; +begin + P:=New(PStringArr,Init); + P^.ReadTo(F,'enddo'); + CompileCode(Acts,P,Name); + Dispose(P,Done); +end; + + constructor TFlashObject.init; + begin + inherited init; + Name:=AName; + PlayName:=APlayName; + upcasestr(Name); + end; + +var CurrObj : PFlashObject; + +procedure ObjError(Msg:string); +begin + ErrorMSG(Str2PChar('ObjErr('+CurrObj^.Name+'): '+Msg)); +end; + + procedure TFlashObject.process; + begin + if field='RES' then Reskey:=Value + else if field='PLAYNAME' then PlayName:=Value; + end; + procedure TFlashObject.chField; + begin + CurrObj:=@Self; + upcasestr(field); + If Field='NAME' then Name:=Value + else If Field='PLAYNAME' then PlayName:=Value + else If Field='RESKEY' then Reskey:=Value + { Reskey part changing } + else If Field='RESX' then add_var('x',value,ResKey) + else if field='RESY' then add_var('y',value,ResKey) + else if field='RESW' then add_var('w',value,Reskey) + else if field='RESH' then add_var('h',value,reskey) + else if field='RESCUR' then add_var('cur',value,reskey) + else if field='RESPIC' then add_var('res',value,reskey) + else if field='RESICO' then add_var('icon',value,reskey); + end; + function TFlashObject.ifField; + {$IFNDEF DELPHI} + var result:boolean; + {$ENDIF} + begin + CurrObj:=@Self; + upcasestr(field); + result:=false; + if field='NAME' then result:=Same(Name,value) + else if field='PLAYNAME' then result:=Same(Playname,value) + else if field='RESX' then result:=Same(Get_Var('x',ResKey),Value) + else if field='RESY' then result:=Same(Get_var('y',reskey),Value) + else if field='RESW' then result:=Same(Get_var('w',reskey),Value) + else if field='RESH' then result:=Same(Get_var('h',reskey),Value) + else if field='RESCUR' then result:=Same(Get_var('cur',reskey),Value) + else if field='RESPIC' then result:=Same(Get_var('res',reskey),Value) + else if field='RESICO' then result:=Same(Get_var('icon',reskey),Value); + IfField:=result; + end; + procedure TFlashObject.Compile; + var Field : IdentString; + Value : TString; + S : String; + begin + CurrObj:=@Self; + repeat + s:=ReadStr(f); formatStr(s); + field:=Argument(s,0); + upcasestr(field); + value:=RestString(s); + process(field,value,f); + until (field='END') or eof(f); + if eof(f) then ErrorMSG('Unexpected eof'); + end; + + constructor TAct.init; + begin + inherited init(AName,APlayName); + New(Acts,init); + end; + destructor TAct.done; + begin + dispose(Acts,done); + inherited done; + end; + procedure TAct.chField; + begin + inherited chField(Field,Value); + upcasestr(Field); + if field='PARAMS' then Params:=Value + else if field='RUN' then Run(Value); + end; + function TAct.ifField; + {$IFNDEF DELPHI} + var result:boolean; + {$ENDIF} + begin + result:=inherited ifField(Field,Value); + UpCaseStr(Field); + if field='PARAMS' then result:=Same(Params,Value) + else if field='ACT' then result:=Acts^.Getname(Value)<>nil; + IfField:=result; + end; + procedure TAct.Process; + begin + inherited process(field,value,f); + if field='DO' then ReadActs(Name,Acts,f) + else if field='WITH' + then Params:=Value; + end; + Procedure TAct.Run; + var a:integer; + begin + if Same(Argument(Params,0),'#') and (cParams<>'') + then begin + InitReplace;ReplaceOn; + for a:=0 to TOInt(Argument(Params,1))-1 do + FlashCom.Replace( Argument(Params,2)+TOStr(a+1), + Argument(cParams,a)); + Acts^.Run; + ReplaceOff; + DoneReplace; + end else if Same(Params,cParams) then Acts^.Run + else Message('Can`t run act'); + end; + constructor TAtmo.init; + begin + inherited init(AName,APlayName); + New(Params,init); + New(Timeline,init); + end; + destructor TAtmo.done; + begin + dispose(Params,done); + dispose(Timeline,done); + inherited done; + end; + procedure TAtmo.chField; + var p:ptimeunit; + begin + inherited chField(Field,Value); + upcasestr(Field); + if field='PARAMS' then ChangeParams(Params,Value) + else if field='PARAM' then ChangeParams(Params,Value) + else if field='EVENT' then begin + p:=TimeLine^.SearchEvent(Value); + if p<>nil then p^.act^.run + else ObjError('Can`t find '+Value+' event'); + end; + end; + function TAtmo.ifField; + {$IFNDEF DELPHI} + var result:boolean; + {$ENDIF} + begin + result:=inherited ifField(Field,Value); + UpCaseStr(Field); + if field='PARAMS' then result:=Same(Params^.Value(Argument(Value,0)),RestString(Value)) + else if field='EVENT' then result:=Same(Timeline^.CurrTimeEvent,Value); + IfField:=result; + end; + procedure TAtmo.Process; + var event:PTimeUnit; + begin + inherited process(field,value,f); + if field='PARAMS' then ReadParams(Params,f) + else if field='PARAM' then Params^.SetValue(Value) + else if field='TIME' then Timeline^.ReadTime(Field+' '+Value) + else if field='TIMEEVENT' then begin + new(Event,init); + event^.read(f); + Timeline^.Put(Event); + end; + end; + + constructor TLocation.init; + begin + inherited init(AName,APlayName); + new(Things,init); + new(Directions,init); + end; + destructor TLocation.done; + begin + dispose(Things,done); + dispose(Directions,done); + inherited done; + end; + procedure TLocation.chField; + begin + inherited chField(Field,Value); + upcasestr(field); + if field='THINGS' then ChangeThings(Things,Value) + else if field='THING' then ChangeThings(Things,Value) + else if field='DIR' then ChangeDirs(Directions,Value); + end; + function TLocation.ifField; + {$IFNDEF DELPHI} + var result:boolean; + {$ENDIF} + begin + result:=inherited ifField(Field,Value); + UpCaseStr(Field); + if field='THING' then result:=Things^.Search(Value)<>-1 + else if field='THINGS' then result:=Things^.Search(Value)<>-1 + else if field='DIR' then result:=Directions^.SearchPart(Value,1)<>-1; + IfField:=result; + end; + procedure TLocation.process; + begin + inherited process(field,value,f); + if field='THINGS' then ReadThings(Things,f) + else if field='THING' then Things^.put(Value) + else if field='DIRS' then ReadDirs(Directions,f); + end; + + procedure TThing.chField; + begin + inherited chField(Field,Value); + upcasestr(field); + if field='PLACE' then Place:=Value; + end; + function TThing.ifField; + {$IFNDEF DELPHI} + var result:boolean; + {$ENDIF} + begin + result:=inherited ifField(Field,Value); + UpCaseStr(Field); + if field='PLACE' then result:=Same(Place,value); + IfField:=result; + end; + procedure TThing.process; + begin + inherited process(field,value,f); + if field='PLACE' then Place:=Value + end; + + constructor TPlayer.init; + begin + inherited init(AName,APlayName); + new(Things,init); + end; + destructor TPlayer.done; + begin + dispose(Things,done); + inherited done; + end; + procedure TPlayer.chField; + begin + inherited chField(Field,Value); + upcasestr(field); + if field='PLACE' then Place:=Value + else if field='THINGS' then ChangeThings(Things,Value) + else if field='THING' then ChangeThings(Things,Value); + end; + function TPlayer.ifField; + {$IFNDEF DELPHI} + var result:boolean; + {$ENDIF} + begin + result:=inherited ifField(Field,Value); + UpCaseStr(Field); + if field='PLACE' then result:=Same(Place,value) + else if field='THING' then result:=Things^.Search(Value)<>-1 + else if field='THINGS' then result:=Things^.Search(Value)<>-1; + IfField:=result; + end; + procedure TPlayer.process; + begin + inherited process(field,value,f); + if field='PLACE' then Place:=Value + else if field='THINGS' then ReadThings(Things,f); + end; + + constructor TFlashCommon.init; + begin + inherited init(AName,APlayName); + New(Acts,init); + New(Text,init); + New(Params,init); + end; + destructor TFlashCommon.done; + begin + dispose(Acts,done); + dispose(Text,done); + dispose(Params,done); + inherited done; + end; + procedure TFlashCommon.chField; + begin + inherited chField(Field,Value); + upcasestr(Field); + if field='TEXT' then ChangeText(Text,Value) + else if field='PARAMS' then ChangeParams(Params,Value) + else if field='PARAM' then ChangeParams(Params,Value) + else if field='RUN' then ChangeCommands(Acts,Value); + end; + function TFlashCommon.ifField; + {$IFNDEF DELPHI} + var result:boolean; + {$ENDIF} + begin + result:=inherited ifField(Field,Value); + UpCaseStr(Field); + if field='PARAMS' then result:=Same(Params^.Value(Argument(Value,0)),RestString(Value)) + else if field='PARAM' then result:=Same(Params^.Value(Argument(Value,0)),RestString(Value)) + else if field='ACT' then result:=Acts^.Getname(Value)<>nil; + IfField:=result; + end; + procedure TFlashCommon.Process; + begin + inherited process(field,value,f); + if field='DO' then ReadActs(Name,Acts,f) + else if field='TEXT' then ReadText(Text,f) + else if field='PARAMS' then ReadParams(Params,f) + else if field='PARAM' then Params^.SetValue(Value); + end; + + +begin +end. \ No newline at end of file diff --git a/UNITS/FLASH/FLSCRIPT.PAS b/UNITS/FLASH/FLSCRIPT.PAS new file mode 100644 index 0000000..200083a --- /dev/null +++ b/UNITS/FLASH/FLSCRIPT.PAS @@ -0,0 +1,137 @@ +{$DEFINE DOFADE} +Unit FlScript; + +interface + +Uses flobjects,flmain,locview,fx_form; + +Var loc_id:tlocrec; + Switches:TSwitches; + dofadeloc:boolean; + ScriptSize,StartSize:LongInt; + Turns:longint; + + Procedure Init(P:PProcessBar; Name:string;var F:Text); + procedure Load(Name:string); + Procedure Done; + Procedure UpDateLocation(Loc:PLocation); + Procedure Go(Dir:flobjects.TString); + Procedure Look; + +implementation + +Uses objects,swset,strconst,kernel,TPStr,Constants, + TPParam,FlashCom,TPTimeLine,core,misc,flgraph, + flaction,textlib,fx_init,fx_mouse,fx_dev, + fx_pens,status,grConst,things; + +procedure Load(Name:string); + var p:pdosstream; +begin + new(p,init(Name,stOPENREAD)); + + FlashMake:=MakeCommand; + FlashCond:=IfCommand; + + player^.restore(P^); + atmo^.restore(p^); + thinglist^.restore(p^); + loclist^.restore(p^); + actlist^.restore(p^); + humanlist^.restore(p^); + + CurrentLoc:=PLocation(LocList^.Find(Player^.Place)); + LastLoc:=CurrentLoc; + If CurrentLoc=nil then ErrorMSG('Player place undefined'); + + done_thinger; + init_thinger; + updatelocation(currentloc); + Atmo^.Timeline^.ProcessEvents; + + dispose(p,done); +end; + +Procedure Init(P:PProcessBar; Name:string;var F:Text); +begin + StartSize:=Memavail; + (* marking system procedures *) + FlashMake:=MakeCommand; + FlashCond:=IfCommand; + (* exracting name of dat file *) + BaseName:=Name; + (* opening database *) + Assign(F,BaseName); + {$I-} Reset(F); {$I+} + If IOResult<>0 then FatalMSG(Str2Pchar('Can`t find '+BaseName)); + (* reading main switches *) + ConfigureSwitches(Switches,F); + (* reading all database *) + InitFile(P,F); + Close(F); + (* output system information *) + ScriptSize:=StartSize-MemAvail; + ScenSize := ScriptSize; + Formtopics(BaseName); +end; + +Procedure Done; +begin + EndTopics; + DoneAll; + Done_Main; +end; + +Procedure Go(Dir:flobjects.TString); +begin + if LocList^.Find(DIR)=nil then ErrorMSG(cNoSuchOut); + LastLoc:=CurrentLoc; + CurrentLoc:=PLocation(LocList^.Find(Dir)); + Player^.Place:=CurrentLoc^.Name; + UpdateLocation(CurrentLoc); +end; + +const frame_showed : boolean = false; + +(* text mode procedures *) +Procedure UpDateLocation(Loc:PLocation); +var a:integer; + h:boolean; + frame:pdevice; + p:pcolorpen; +begin + if dofadeloc then Palette^.fadeto(Black^,cFadeTime); + remove_all; + loc2locrec(loc,loc_id); + + hide_mouse; + done_status; + +{ new(p,init(0)); + screen^.map( 0,0,259,174, p ); + dispose(p,done);} + + show_locrec(loc_id,screen); + if not frame_showed then begin + frame:=new(PDEVICE,load(res^.loadres('FRAME')^)); + frame^.fulldevicecopy0(0,0,screen); + dispose(frame,done); + frame_showed := true; + end; + init_status; + statusline(MousePosX,MousePOSY); + show_mouse; + + if dofadeloc then Palette^.fadefrom(Black^,cFadeTime); +end; + +Procedure Look; +begin + dofadeloc:=false; + UpdateLocation(CurrentLoc); + dofadeloc:=true; +end; + + +end. + diff --git a/UNITS/FLASH/FONTED.PAS b/UNITS/FLASH/FONTED.PAS new file mode 100644 index 0000000..1c10219 --- /dev/null +++ b/UNITS/FLASH/FONTED.PAS @@ -0,0 +1,275 @@ +Unit FontEd; + +interface + + procedure FontEdit; + +implementation + + Uses data,tpstr,flgraph,misc,fx_types,fx_mouse,fx_pens,types,fx_init,fx_fonts,fx_form,fx_dev; + + + const + cFontEdX = 10; + cFontEdY = 10; + cFontEdW = 240; + cFontEdH = 150; + cCurrNum = 65; + cFontEdMsg = 'Built-in FontEditor (C) 1996 Wizecore'; + cStatEdMsg = 'Press ALT-X to exit'; + + { color choosing buttons } + cColorSect = 'Color selection'; + cPalSelMsg = 'Color'; + cGlassMsg = 'Darken'; + cBrightMsg = 'Brighten'; + { symbol choosing buttons } + cCharSect = 'Char selection'; + cNextMsg = 'Next(+)'; + cPrevMsg = 'Prev(-)'; + cSelMsg = 'Select(Num)'; + { file option buttons } + cFileSect = 'File Selection'; + cLoadMsg = 'Load'; + cSaveMsg = 'Save'; + cNewMsg = 'New'; + { miscelangelous button } + cMiscMsg = 'Misc...'; + + cColWinL = 11; + + Var CurrentFont:PFont; + CurrentChar:Char; + filename:nstring; + + procedure FontEdit; + var Zoom:PZoomEdit; + ax,ay,fw,fh,bh,aw,ah,sx,sy,x,y:integer; + ColX,ColY:Integer; + NumX,NumY:Integer; + LeftColor,RightColor:PPen; + CurrentDev:PDevice; + CurrentSym:Byte; + Button:Byte; + Form:PForm; + Ch:PChar; + + { color choosing buttons } + PalChoose, + GlassChoose, + BrightChoose, + { symbol choosing buttons } + NextChar, + PrevChar, + SelChar, + { file option buttons } + SaveFnt, + LoadFnt, + NewFnt, + { miscelangelous button } + MiscMenu:PButton; + + function StdButton(Name:String):PButton; + begin + StdButton:=New(PButton,Init(Name,LightFont^.LnWidth(Name)+1)); + end; + + function PickCol:PPen; + begin + PickCol:=New(PColorPen,Init(PickColor(x,y))); + end; + + procedure ClearNum; + var p:PColorPen; + begin + New(P,init(Colors.Paper)); + Screen^.Map(NumX,NumY,NumX+LightFont^.lnWidth(ToStr(CurrentSym)+':'+Chr(CurrentSym))-1,NumY+LightFont^.lnHeight-1,P); + Dispose(P,Done); + end; + + begin + CurrentFont:=nil; + CurrentSym:=0; + filename:=''; + form:=make_form(Pix1_fr,Std_Ground,LightFont); + form^.Show(Screen,cFONTEDX,cFONTEDY,cFONTEDX+cFONTEDW-1,cFONTEDY+cFONTEDH-1); + sx:=cFONTEDX+form^.offsetx+1; + sy:=cFONTEDY+form^.offsety+1; + aw:=cFONTEDW-(form^.offsetx+1)*2; + ah:=cFONTEDH-(form^.offsety+1)*2; + LightFont^.WriteCen(sx,sy,aw,Screen,cFontEdMsg); + LightFont^.WriteCen(sx,sy+ah-LightFont^.lnHeight-2,aw,Screen,cStatEdMsg); + sy:=sy+LightFont^.lnHeight+2; + ah:=ah-(LightFont^.lnHeight+2)*2; + PalChoose :=StdButton(cPalSelMsg); + GlassChoose :=StdButton(cGlassMsg); + BrightChoose :=StdButton(cBrightMsg); + NextChar :=StdButton(cNextMsg); + PrevChar :=StdButton(cPrevMsg); + SelChar :=StdButton(cSelMsg); + NewFnt :=StdButton(cNewMsg); + LoadFnt :=StdButton(cLoadMsg); + SaveFnt :=StdButton(cSaveMsg); + MiscMenu :=StdButton(cMiscMsg); + + bh:=PalChoose^.Height+1; + + ax:=sx; ay:=sy; + LightFont^.Writeln(ax,ay+3,Screen,cColorSect); + inc(ax,LightFont^.lnWidth(cColorSect)); + PalChoose^.Show(ax,aY); Inc(ax,PalChoose^.Width+1); + GlassChoose^.Show(ax,ay); Inc(ax,GlassChoose^.Width+1); + BrightChoose^.Show(ax,aY); Inc(Ax,BrightChoose^.Width+1); + ColX:=ax; ColY:=ay; + + ax:=sx; ay:=sy+bh; + LightFont^.Writeln(ax,ay+3,Screen,cCharSect); + inc(ax,LightFont^.lnWidth(cCharSect)); + PrevChar^.Show(ax,ay); Inc(ax,PrevChar^.Width+1); + SelChar^.Show(ax,ay); Inc(ax,SelChar^.Width+1); + NextChar^.Show(ax,ay); Inc(ax,NextChar^.Width+1); + NumX:=ax+2; NumY:=ay+3; + + ax:=sx; ay:=sy+bh*2; + LightFont^.Writeln(ax,ay+3,Screen,cFileSect); + inc(ax,LightFont^.lnWidth(cFileSect)); + NewFnt^.Show(ax,ay); Inc(ax,NewFnt^.Width+1); + LoadFnt^.Show(ax,ay); Inc(ax,LoadFnt^.Width+1); + SaveFnt^.Show(ax,ay); Inc(ax,SaveFnt^.Width+1); + MiscMenu^.Show(ax,ay); + sy:=sy+bh*3; + CurrentDev:=nil; + RightColor:=nil; + LeftColor:=New(PColorPen,Init(0)); + Screen^.Map(ColX,ColY,ColX+cCOLWINL-1,COLY+cCOLWINL-1,LeftColor); + Screen^.Map(ColX+cCOLWINL,ColY,ColX+cCOLWINL*2-1,COLY+cCOLWINL-1,LeftColor); + LightFont^.Writeln(ColX+2,Coly+3,Screen,'X'); + LightFont^.Writeln(ColX+2+cCOLWINL,ColY+3,Screen,'X'); + Dispose(LeftColor,Done); LeftColor:=Nil; + LightFont^.Writeln(NumX,NumY,Screen,TOStr(CurrentSym)+':'+Chr(CurrentSym)); + While Not ALTX_PRESSED do begin + x:=MousePosX; y:=MousePosY; + if MouseButtons<>0 then begin + Button:=MouseButtons; + if NextChar^.Here(x,y) then begin + Hide_mouse; + NextChar^.Repaint_act; + Show_mouse; + ClearNum; + if Button=cLeftButton + then Inc(CurrentSym) + else Inc(CurrentSym,10); + LightFont^.Writeln(NumX,NumY,Screen,TOStr(CurrentSym)+':'+Chr(CurrentSym)); + end; + if PrevChar^.Here(x,y) then begin + Hide_mouse; + PrevChar^.Repaint_act; + Show_mouse; + ClearNum; + if Button=cLeftButton + then Dec(CurrentSym) + else Dec(CurrentSym,10); + LightFont^.Writeln(NumX,NumY,Screen,TOStr(CurrentSym)+':'+Chr(CurrentSym)); + end; + if (CurrentDev<>Nil) and Zoom^.Here(x,y) and Zoom^.InZoom(x,y) + then case Button of + cLeftButton : if LeftColor<>Nil + then Zoom^.ZoomClick(x,y,LeftColor) + else Message('Pen have no color'); + cRightButton : if RightColor<>Nil + then Zoom^.ZoomClick(x,y,RightColor) + else Message('Pen have no color'); + end; + if PalChoose^.Here(x,y) + then begin + Hide_mouse; + PalChoose^.Repaint_act; + Show_mouse; + case Button of + cLeftButton : begin + if LeftColor<>Nil then Dispose(LeftColor,Done); + LeftColor:=PickCol; + Screen^.Map(ColX,ColY,ColX+cCOLWINL-1,COLY+cCOLWINL-1,LeftColor); + end; + cRightButton: begin + if RightColor<>Nil then Dispose(RightColor,Done); + RightColor:=PickCol; + Screen^.Map(ColX+cCOLWINL,ColY,ColX+cCOLWINL*2-1,COLY+cCOLWINL-1,RightColor); + end; + end; + end; + if GlassChoose^.Here(x,y) + then begin + Hide_mouse; GlassChoose^.Repaint_act; Show_mouse; + case Button of + cLeftButton : begin + if LeftColor<>Nil then Dispose(LeftColor,Done); + + LeftColor:=New(PColorPen,Init(0)); + Screen^.Map(ColX,ColY,ColX+cCOLWINL-1,COLY+cCOLWINL-1,LeftColor); + LightFont^.Writeln(ColX+2,Coly+3,Screen,'G'); + Dispose(LeftColor,Done); + + LeftColor:=New(PConvertPen,Init(Palette^.GlassIndex)); + end; + cRightButton: begin + if RightColor<>Nil then Dispose(RightColor,Done); + + LeftColor:=New(PColorPen,Init(0)); + Screen^.Map(ColX+cCOLWINL,ColY,ColX+cCOLWINL*2-1,COLY+cCOLWINL-1,LeftColor); + LightFont^.Writeln(ColX+2+cCOLWINL,ColY+3,Screen,'G'); + Dispose(LeftColor,Done); + + RightColor:=New(PConvertPen,Init(Palette^.GlassIndex)); + end; + end; + end; + if BrightChoose^.Here(x,y) + then begin + Hide_mouse; BrightChoose^.Repaint_act; Show_mouse; + case Button of + cLeftButton : begin + if LeftColor<>Nil then Dispose(LeftColor,Done); + + LeftColor:=New(PColorPen,Init(0)); + Screen^.Map(ColX,ColY,ColX+cCOLWINL-1,COLY+cCOLWINL-1,LeftColor); + LightFont^.Writeln(ColX+2,Coly+3,Screen,'B'); + Dispose(LeftColor,Done); + + LeftColor:=New(PConvertPen,Init(Palette^.BrightIndex)); + end; + cRightButton: begin + if RightColor<>Nil then Dispose(RightColor,Done); + + LeftColor:=New(PColorPen,Init(0)); + Screen^.Map(ColX+cCOLWINL,ColY,ColX+cCOLWINL*2-1,COLY+cCOLWINL-1,LeftColor); + LightFont^.Writeln(ColX+2+cCOLWINL,ColY+3,Screen,'B'); + Dispose(LeftColor,Done); + + RightColor:=New(PConvertPen,Init(Palette^.BrightIndex)); + end; + end; + end; + end; + While MouseButtons<>0 do; + end; + Hide_Mouse; + Dispose(PalChoose,Done); + Dispose(GlassChoose,Done); + Dispose(BrightChoose,Done); + Dispose(NextChar,Done); + Dispose(PrevChar,Done); + Dispose(SelChar,Done); + Dispose(NewFnt,Done); + Dispose(LoadFnt,Done); + Dispose(SaveFnt,Done); + Dispose(MiscMenu,Done); + form^.unshow; + Dispose(Form,Done); + if CurrentFont<>nil then Dispose(CurrentFont,Done); + if LeftColor<>nil then Dispose(LeftColor,Done); + if RightColor<>nil then Dispose(RightColor,Done); + Show_Mouse; + end; + +end. \ No newline at end of file diff --git a/UNITS/FLASH/FONTEDIT.PAS b/UNITS/FLASH/FONTEDIT.PAS new file mode 100644 index 0000000..113d32e --- /dev/null +++ b/UNITS/FLASH/FONTEDIT.PAS @@ -0,0 +1,310 @@ +Unit FontEdit; + +interface + +procedure FontEditor; + +implementation + + Uses objects,tpdos,tpcrt,strings,data,tpstr,flgraph, + misc,fx_types,fx_mouse, + fx_pens,types,fx_init, + fx_fonts,fx_form,fx_dev,fx_menu; + +Const cNew_id = 01; + cLoad_id = 02; + cSave_id = 03; + cExit_id = 04; + + cColorCh_id = 11; + cGlass_id = 12; + cBright_id = 13; + + cPrev_id = 21; + cNext_id = 22; + cSelect_id = 23; + + function InitMenu:PMenuList; + var Main:PMenuHor; + FileMenu, + ColorMenu, + CharMenu:PMenuVer; + begin + New(Main,Init(3)); + New(FileMenu,Init(4)); + FileMenu^.PutItem('New',New(PMenuId,Init(cNew_id))); + FileMenu^.PutItem('Load',New(PMenuId,Init(cLoad_id))); + FileMenu^.PutItem('Save',New(PMenuId,Init(cSave_id))); + FileMenu^.PutItem('Exit',New(PMenuId,Init(cExit_id))); + Main^.PutItem('File',FileMenu); + New(ColorMenu,Init(3)); + ColorMenu^.PutItem('Color...',New(PMenuId,Init(cColorCh_id))); + ColorMenu^.PutItem('Glass',New(PMenuId,Init(cGlass_id))); + ColorMenu^.PutItem('Bright',New(PMenuId,Init(cBright_id))); + Main^.PutItem('Pen',ColorMenu); + New(CharMenu,init(3)); + CharMenu^.PutItem('Previous',New(PMenuId,Init(cPrev_id))); + CharMenu^.PutItem('Next',New(PMenuId,Init(cNext_id))); + CharMenu^.PutItem('Select',New(PMenuId,Init(cSelect_id))); + Main^.PutItem('Char',CharMenu); + InitMenu:=Main; + end; + + var Key:Word; + + function ReadKeyWord:Word; + var key:word; + begin + key:=0; + key:=Ord(ReadKey); + if key=0 then key:=ord(Readkey)*256; + ReadKeyWord:=key; + end; + +function CheckKey(AKey:word):boolean; +begin + CheckKey:=Key=AKey; +end; + + const + cZOOMPOSX = 10; + cZOOMPOSY = 10; + + cGLASSCODE1 =$0067; + cGLASSCODE2 =$2200; + cBRIGHTCODE1 =$0062; + cBRIGHTCODE2 =$3000; + cCOLORCODE1 =$0063; + cCOLORCODE2 =$2E00; + cHELPCODE =$3B00; + cSTATCODE =$3C00; + cZOOMCODE =Ord('z'); + var LeftCol, RightCol:byte; + + procedure EditChar(Char:PChar; Var ZoomLev:byte); + var Dev:PDevice; + Zoom:PZoomEdit; + Left,Right:PPen; + x,y:integer; + butt:Byte; + c:byte; + + procedure HelpScreen; + begin + Writeline('Press "C" to color select'); + Writeline('Press "G" to glass'); + Writeline('Press "B" to bright'); + Writeline('Press "Z" to change zoom'); + Writeline('- all for left pen, for right - same key + ALT'); + SHow_text; + end; + + begin + Dev:=Char2Dev(Char); + New(Zoom,Init(ZoomLev,Dev,False)); + Hide_mouse; Zoom^.Show(cZOOMPOSX,cZOOMPOSY); Show_mouse; + Left:=New(PColorPen,init(LeftCol)); Right:=New(PColorPen,init(RightCol)); + While true do begin + x:=MousePosX; y:=MousePosY; + if MouseButtons<>0 then begin + butt:=MouseButtons; ClearInput; + if Zoom^.InZoom(x,y) then case Butt of + cLeftButton : if Assigned(Left) + then begin + Hide_mouse; + Zoom^.ZoomClick(x,y,Left); + Show_mouse; + end else Message('No pen assigned to left button'); + cRightButton : if Assigned(Right) + then begin + Hide_mouse; + Zoom^.ZoomClick(x,y,Right); + Show_mouse; + end else Message('No pen assigned to right button'); + end; + end; + if Keypressed then Key:=ReadKeyWord else Key:=0; + if CheckKey(cHELPCODE) then HelpScreen; + if CheckKey(cCOLORCODE1) then begin + if Left<>nil then Dispose(Left,Done); + c:=PickColor(x,y); LeftCol:=c; + Left:=New(PCOlorPen,Init(c)); + end; + if CheckKey(cCOLORCODE2) then begin + if Right<>nil then Dispose(Right,Done); + c:=PickColor(x,y); RightCol:=c; + Right:=New(PCOlorPen,Init(c)); + end; + if CheckKey(cGLASSCODE1) then begin + if Left<>nil then Dispose(Left,Done); + Left:=New(PConvertPen,Init(Palette^.GlassIndex)); + end; + if CheckKey(cGLASSCODE2) then begin + if Right<>nil then Dispose(Right,Done); + Right:=New(PConvertPen,Init(Palette^.GlassIndex)); + end; + if CheckKey(cBrightCODE1) then begin + if Left<>nil then Dispose(Left,Done); + Left:=New(PConvertPen,Init(Palette^.BrightIndex)); + end; + if CheckKey(cBrightCODE2) then begin + if Right<>nil then Dispose(Right,Done); + Right:=New(PConvertPen,Init(Palette^.BrightIndex)); + end; + if CheckKey($001b) then Break; + if CheckKey(cZOOMCODE) then begin + ZoomLev:=TOByte(Receive('ZOOM?(4-20)')); + if not belongs(ZoomLev,4,20) then ZoomLev:=4; + Hide_mouse; Dispose(Zoom,Done); Show_mouse; + New(Zoom,Init(ZoomLev,Dev,False)); + Hide_mouse; Zoom^.Show(cZOOMPOSX,cZOOMPOSY); Show_mouse; + end; + if checkkey(ord('f')) then begin + Dev^.Clear(Left); + Hide_mouse; Zoom^.Hide; Show_mouse; + Hide_mouse; Zoom^.Show(cZOOMPOSX,cZOOMPOSY); Show_mouse; + end; + + end; + if Left<>nil then Dispose(Left,Done); + if Right<>nil then Dispose(Right,Done); + Hide_mouse; Dispose(Zoom,Done); Show_mouse; + PutDev2Char(Dev,Char); + Dispose(Dev,Done); + end; + +procedure FontEditor; + var Zoom:Byte; + Font:PFont; + Data:PDosStream; + FileName:String; + Symbol:Byte; + Wid,Hgt:Byte; + Win:PTextWindow; + Char:PChar; + a,b:integer; + + procedure StatusScreen; + begin + Writeline('Current fonteditor status'); + Writeline('Left pen color: '+tostr(LeftCol)); + Writeline('Right pen color: '+tostr(RightCol)); + Writeline('Font filename: '+filename); + Writeline('Current Symbol #'+TOStr(Symbol)+' Char:'+System.Chr(Symbol)); + Writeline('Font height: '+ToStr(Hgt)); + Show_text; + end; + +begin + Zoom:=10; Font:=Nil; Symbol:=0; LeftCol:=80; RightCol:=0; + While true do begin + if Keypressed then Key:=ReadKeyWord else Key:=0; + case Key of + cHelpcode : begin + Writeline('n,l,s - new,save,load font'); + Writeline('c - set symbol as char'); + writeline('d - set symbol as code'); + Writeline('h - change default height of symbols'); + writeline('v - preview'); + writeline('q - quit'); + writeline('e - edit current symbol'); + writeline('r - shrink or expand width of current symbol'); + writeline('",","." - scrolls through symbols'); + show_text; + end; + cSTATCODE : StatusScreen; + ord('l') : begin + Filename:=Receive('Load?'); + if Filename='' then continue else begin + If Pos('.',Filename)=0 then Filename:=Filename+'.fnt'; + if ExistFile(Filename) then begin + New(Data,init(FIlename,stOPENREAD)); + New(Font,Load(Data^)); + Dispose(Data,Done); + Symbol:=65; + Hgt:=Font^.lnHeight; + end else Message('Can`t find such file'); + end; + end; + ord('s') : begin + if Font=Nil then begin + Message('No font currently edited'); + Continue; + end; + Filename:=Receive('Save?'); + if Filename='' then continue else begin + If Pos('.',Filename)=0 then Filename:=Filename+'.fnt'; + New(Data,init(Filename,stCreate)); + Font^.Store(Data^); + Dispose(Data,Done); + end; + end; + ord('n') : begin + if Font<>Nil then Dispose(FOnt,Done); + Hgt:=ToByte(Receive('Font height?')); + New(Font,Init(1,1)); + end; + ord('c') : begin + Filename:=Receive('Char?'); + Symbol:=Ord(Filename[1]); + Filename:=''; + end; + ord('d') : begin + Symbol:=TOByte(Receive('Code?')); + end; + ord('h') : Hgt:=ToByte(Receive('Font height?')); + ord('e') : begin + if Font=nil + then Message('No font available') + else begin + if Font^.Get(Symbol) = nil + then begin + Wid:=TOByte(Receive('Char width?')); + if Wid=0 then Continue; + Font^.Put(Symbol,New(PChar,Init(Wid,Hgt))); + EditChar(Font^.Get(Symbol),Zoom); + end else EditChar(Font^.Get(Symbol),Zoom); + end; + end; + ord('q') : Break; + ord('r') : begin + if Font=nil then begin + Message('No font loaded'); + continue; + end; + Wid:=ToByte(Receive('New width?')); + if Font^.List[Symbol]=nil then New(Font^.List[Symbol],Init(Wid,Hgt)); + if Wid<>0 then begin + New(Char,Init(Wid,Hgt)); + if Wid>Font^.Get(Symbol)^.chWidth + then Wid:=Font^.Get(Symbol)^.chWidth; + for b:=0 to Hgt-1 do + for a:=0 to Wid-1 do Char^.SetPin(a,b,Font^.Get(Symbol)^.GetPin(a,b)); + Dispose(Font^.List[Symbol],Done); + Font^.List[Symbol]:=Char; + end; + end; + ord('v') : begin + if Font=nil then begin + Message('No font loaded'); + continue; + end; + Filename:=Receive('Enter chars'); + New(Win,Init( 1,Font^.lnWidth(Filename)+5, + make_form(pix1_fr, std_ground, Font), + Screen )); + Win^.put(Filename); + Win^.Center; + anyclick; + Dispose(Win,done); + end; + ord('.') : if Symbol=255 then Symbol:=0 else inc(Symbol); + ord(',') : if Symbol=0 then Symbol:=255 else Dec(Symbol); + + end; + end; + if Font<>nil then Dispose(Font,Done); +end; + +end. + diff --git a/UNITS/FLASH/GLASS.PAS b/UNITS/FLASH/GLASS.PAS new file mode 100644 index 0000000..240a760 --- /dev/null +++ b/UNITS/FLASH/GLASS.PAS @@ -0,0 +1,48 @@ +Unit Glass; + +interface + + procedure do_glass; + procedure undo_glass; + +implementation + +Uses data,kernel,core,streams,things,flgraph,types, + fx_mouse,fx_pens,fx_types,flscript,flaction,fx_dev, + fx_fonts,fx_pal,res_type,fx_shape,constants,flashcom, + sysinfo,time,fx_init,imgstack,flobjects,locview,buttons; + +var save_glass:pdevice; + +procedure do_glass; + var + glass:pconvertpen; + temp:pdevice; +begin + {$IFDEF DOGLASS} + save_glass:=New(PDevice,init(cVIEW.W,cVIEW.H)); + temp:=New(PDevice,init(cVIEW.W,cVIEW.H)); + screen^.partdevicecopy(0,0,cVIEW.X,cVIEW.Y,cVIEW.W,cVIEW.H,save_glass); + screen^.partdevicecopy(0,0,cVIEW.X,cVIEW.Y,cVIEW.W,cVIEW.H,temp); + + new(glass,init(Palette^.GlassIndex)); + hide_mouse; + temp^.clear(glass); + temp^.fulldevicecopy(cVIEW.X,cVIEW.Y,screen); + show_mouse; + dispose(glass,done); + dispose(temp,done); + {$ENDIF} +end; + +procedure undo_glass; +begin + {$IFDEF DOGLASS} + hide_mouse; + save_glass^.fulldevicecopy(cVIEW.X,cVIEW.Y,screen); + show_mouse; + dispose(save_glass,done); + {$ENDIF} +end; + +end. \ No newline at end of file diff --git a/UNITS/FLASH/GRCONST.PAS b/UNITS/FLASH/GRCONST.PAS new file mode 100644 index 0000000..bb198a3 --- /dev/null +++ b/UNITS/FLASH/GRCONST.PAS @@ -0,0 +1,19 @@ +Unit GRConst; + + interface + + const + cFadeTime = 8; + cDreamsLine = 'Эхо снов(Dreams) от WIZECORE 1995,96 год.'; + cSwitchNotify = 'Добавьте в команднyю стpокy "/?" для паpаметpов запyска'; + cDoingExit = 'Exiting to DOS.'; + cCantFindRes = 'В текyщем каталоге не обнаpyжен файл pесypсов '; + + cVGA_INIT = 'vga.init'; + cVGA_DONE = 'vga.done'; + cRES_INIT = 'resource.init'; + cRES_DONE = 'resource.done'; + + implementation + + end. \ No newline at end of file diff --git a/UNITS/FLASH/GR_ERR.PAS b/UNITS/FLASH/GR_ERR.PAS new file mode 100644 index 0000000..7d4ba9a --- /dev/null +++ b/UNITS/FLASH/GR_ERR.PAS @@ -0,0 +1,39 @@ +Unit gr_err; + +interface + +procedure set_gr_io; + +implementation + +uses tpstr,flgraph,fx_init,core; + +procedure gr_message(message:string); +begin + Palette^.Apply; + FLGraph.Message(Message); +end; + + const + cYESignore = 'Да, игноpиpовать'; + cNoIgnore = 'Hет, выйти'; + cPRomt_X = 100; + cPromt_Y = 60; + cDOIgnore = 'Пpоигноpиpовать ?'; + +function gr_yes_no(message:string):boolean; + var text:PStringArr; +begin + New(Text,Init); + Text^.Put(cYESIgnore); + Text^.Put(cNoIgnore); + gr_yes_no:=Show_arr(cPROMT_X,cPROMT_Y,cDOIgnore,Text)=0; + Dispose(Text,Done); +end; + +procedure set_gr_io; +begin + SetIOMethods(gr_Message,gr_yes_no); +end; + +end. \ No newline at end of file diff --git a/UNITS/FLASH/IMGSTACK.PAS b/UNITS/FLASH/IMGSTACK.PAS new file mode 100644 index 0000000..769a30e --- /dev/null +++ b/UNITS/FLASH/IMGSTACK.PAS @@ -0,0 +1,118 @@ +Unit imgstack; + +interface + +uses objects,streams,fx_dev; +{$I locrange.pas} +const + cmaxsize=64; +type + pimage_stack=^timage_stack; + timage_stack=object(tobject) + { offsets in stream for images } + image:array[0..cmaxsize-1] of longint; + images:byte; + { work stream - there is images stored } + stream:pworkstream;{pxmsstream;} + constructor init; + function store(p:pdevice):byte; + function get(i:word):pdevice; + + procedure show(n,x,y:word;at:pdevice); + procedure show0(n,x,y:word; at:pdevice); + + procedure center(n:word; at:pdevice); + { show part x,y,x1,y1 of n image } + procedure part(n:word; x,y,x1,y1:word; at:pdevice); + destructor done; virtual; + end; +implementation +uses kernel,misc,core; + procedure timage_stack.part; + var i:pdevice; + begin + if belongs(n,0,images) then + begin + stream^.seek(image[n]); + new(i,load(stream^)); + i^.partdevicecopy(x,y,x,y,x1-x+1,y1-y+1,at); + dispose(i,done); + end else fatalMSG('no such image stored'); + end; + function timage_stack.store; + begin + if images=cmaxsize + then fatalMSG('can`t store more images') + else begin + store:=images; + image[images]:=stream^.getpos; + inc(images); + p^.store(stream^); + end; + end; + function timage_stack.get; + var d:pdevice; + begin + if belongs(i,0,images) then + begin + stream^.seek(image[i]); + new(d,load(stream^)); + get:=d; + end else fatalMSG('no such image stored'); + end; + + procedure timage_stack.show; + var i:pdevice; + begin + if belongs(n,0,images) then + begin + stream^.seek(image[n]); + new(i,load(stream^)); + i^.fulldevicecopy(x,y,at); + dispose(i,done); + end else fatalMSG('no such image stored'); + end; + procedure timage_stack.show0; + var i:pdevice; + begin + if belongs(n,0,images) then + begin + stream^.seek(image[n]); + new(i,load(stream^)); + i^.fulldevicecopy0(x,y,at); + dispose(i,done); + end else fatalMSG('no such image stored'); + end; + procedure timage_stack.center; + var i:pdevice; + x,y:word; + begin + if belongs(n,0,images) then + begin + stream^.seek(image[n]); + new(i,load(stream^)); +{ x:=(at^.width-i^.width) div 2 ; + y:=(at^.height-i^.height) div 2 ;} +{ if (loc_width0 then for a:=stack_size-1 downto 0 do tprocedure(exit_stack[a]); + if HeapWas<>MemAvail + then Writeln('Heap ',HeapWas-MemAvail,' bytes unfreed'); + if EMSWas<>EMS_MemAvail + then Writeln('EMS ',EMSWas-EMS_MemAvail,' bytes unfreed'); + if XMSWas<>XMS_MemAvail + then Writeln('XMS ',XMSWas-XMS_MemAvail,' bytes unfreed'); +end; + +procedure init_exit_stack; +begin + SetCloseHandler(@run_exit_stack); + stack_size:=0; +end; + +procedure add_exit_proc(proc:pointer); +begin + if stack_size=cEXIT_STACK_SIZE + then ErrorMSG('Can_t add more procedures at exit') + else begin + exit_stack[stack_size]:=proc; + inc(stack_size); + end; +end; + +begin + HeapWas:=MemAvail; + EMSWas:=EMS_MEMAVAIl; + XMSWas:=XMS_MemAvail; + initiate_core; + init_exit_stack; +end. \ No newline at end of file diff --git a/UNITS/FLASH/LOCVIEW.PAS b/UNITS/FLASH/LOCVIEW.PAS new file mode 100644 index 0000000..3804554 --- /dev/null +++ b/UNITS/FLASH/LOCVIEW.PAS @@ -0,0 +1,431 @@ +{$DEFINE DEBUG_RECT} +{.$DEFINE TEXT_INFO} +Unit locview; + +interface + + uses core,misc,flobjects,kernel,tpstr, + fx_init,fx_dev, + imgstack,data, + fx_pens,constants,fx_mouse,fx_shape; + +const + { maximal amount of objects on screen } + cmaxobjects = 32; + { maximal amount of dirs on screen } + cmaxdirs = 8; + + cDEFAULT_FIND = ''; + cDEFAULT_NAME = ''; + cDEFAULT_VIEW = ''; + cDEFAULT_CUR = ''; + cDEFAULT_X = 0; + cDEFAULT_Y = 0; + cDEFAULT_W = 1; + cDEFAULT_H = 1; + + cVAR_VIEW = 'res'; + cVAR_CUR = 'cur'; + cVAR_ICON = 'icon'; + cVAR_X = 'x'; + cVAR_Y = 'y'; + cVAR_W = 'w'; + cVAR_H = 'h'; + +type + tstring=string[16]; + nstring=string[32]; + + tobjrec=record + { find key } + find:tstring; + { representative name } + name:nstring; + + { resource related } + view:tstring; { .dev file } + cur :tstring; { .cur file } + x :integer; { horiz position on screen } + y :integer; { vert position on screen } + w :word; { active area width } + h :word; { active area height } + end; + +type + plocrec=^tlocrec; + tlocrec=record + self:tobjrec; + + objrec:array[0..cmaxobjects-1] of tobjrec; + objcnt:integer; + + dirrec:array[0..cmaxdirs-1] of tobjrec; + dircnt:integer; + end; + + function contains_objrec(x,y:integer; var objrec:tobjrec):boolean; + procedure show_view_objrec(var objrec:tobjrec; screen:pdevice); + procedure show_cur_objrec(var objrec:tobjrec); + procedure show_objrec(var objrec:tobjrec; screen:pdevice); + procedure new_objrec(var objrec:tobjrec); + procedure unpack_str(pack:string; var objrec:tobjrec); + procedure pack_str(objrec:tobjrec; var s:string); + procedure class2objrec(Kind:PFlashobject; var objrec:tobjrec); + procedure dir2objrec(dir:string; var objrec:tobjrec); + + procedure loc2locrec(loc:plocation; var locrec:tlocrec); + function is_dir(x,y:integer; var locrec:tlocrec):boolean; + function get_objrec(x,y:integer; var locrec:tlocrec; var objrec:tobjrec):boolean; + function get_name(x,y:integer; var locrec:tlocrec):nstring; + function get_find(x,y:integer; var locrec:tlocrec):tstring; + procedure del_objrec(find:tstring; var locrec:tlocrec; var objrec:tobjrec); + + procedure hide_find(find:tstring; var locrec:tlocrec; screen:pdevice); + procedure show_locrec(var locrec:tlocrec; screen:pdevice); + +implementation + +uses crt,fx_fonts,flgraph,play,sounds; + +const + + fullcopy : boolean = true; + showingloc : boolean = true; + + function contains_objrec(x,y:integer; var objrec:tobjrec):boolean; + begin + contains_objrec + := belongs(x,objrec.x,objrec.x+objrec.w-1) and + belongs(y,objrec.y,objrec.y+objrec.h-1); + end; + + procedure show_view_objrec(var objrec:tobjrec; screen:pdevice); + var view:pdevice; + begin + if objrec.view<>cDEFAULT_VIEW then begin + view:=new(PDevice,Load(res^.loadres(objrec.view)^)); + if showingloc + then view^.partdevicecopy(objrec.x+6,objrec.y+6,6,6,view^.width-12,view^.height-12,screen) + else view^.fulldevicecopy0(objrec.x,objrec.y,screen); + +{ begin + if fullcopy + then view^.fulldevicecopy(objrec.x,objrec.y,screen) + else end else } + dispose(view,done); + end; + end; + + procedure hide_view_objrec(locx,locy:integer; locview:tstring; var objrec:tobjrec; screen:pdevice); + var view:pdevice; + P:PColorPen; + begin + if locview<>cDEFAULT_VIEW then begin + view:=new(PDevice,Load(res^.loadres(locview)^)); + hide_mouse; PlaySOund(sndClick); + view^.partdevicecopy( objrec.x,objrec.y, + objrec.x-locx,objrec.y-locy, + objrec.w,objrec.h, + screen); + show_mouse; + dispose(view,done); + end else begin + New(P,init(0)); + Screen^.Map( objrec.x,objrec.y, + objrec.x+objrec.w-1,objrec.y+objrec.h-1 + ,p); + Dispose(P,Done); + end; + + end; + + procedure show_cur_objrec(var objrec:tobjrec); + var cur:pcursor; + begin + if objrec.cur<>cDEFAULT_CUR then begin + cur:=new(PCursor,Load(res^.loadres(objrec.cur)^)); + put_handler(cur,objrec.x,objrec.y,objrec.x+objrec.w-1,objrec.y+objrec.h-1); + dispose(cur,done); + end; + end; + procedure hide_cur_objrec(var objrec:tobjrec); + begin + removehand(objrec.x,objrec.y,objrec.x+objrec.w-1,objrec.y+objrec.h-1); + end; + + procedure hide_objrec(var locrec:tlocrec; var objrec:tobjrec; screen:pdevice); + begin + hide_cur_objrec(objrec); + hide_view_objrec(locrec.self.x,locrec.self.y,locrec.self.view,objrec,screen); + end; + + { next func makes a string to view as debugging } + function view_objrec(font:pfont; objrec:tobjrec):string; + var ax,ay:integer; + begin + with objrec do begin + ax:=x; ay:=y; + font^.writeln(ax,ay,screen,'find:' + find); + ay:=ay+font^.lnHeight; + font^.writeln(ax,ay,screen,'name:' + name); + ay:=ay+font^.lnHeight; + font^.writeln(ax,ay,screen,'view:' + view); + ay:=ay+font^.lnHeight; + font^.writeln(ax,ay,screen,'cur_:' + cur ); + ay:=ay+font^.lnHeight; + font^.writeln(ax,ay,screen, 'x:'+tostr(x)+ + ' y:'+tostr(y)+ + ' w:'+tostr(w)+ + ' h:'+tostr(h)); + end; + end; + + procedure show_objrec(var objrec:tobjrec; screen:pdevice); + var p:pcolorpen; + begin + show_view_objrec(objrec,screen); + show_cur_objrec(objrec); + + {$IFDEF TEXT_INFO} + view_objrec(lightfont,objrec); + {$ENDIF} + + {$IFDEF DEBUG_RECT} + new(p,init(111)); + with objrec do screen^.rectangle(x,y,x+w-1,y+h-1,p); + dispose(p,done); + {$ENDIF} + end; + + { next proc forms default/not active objrec } + procedure new_objrec(var objrec:tobjrec); + begin + with objrec do begin + find := cDEFAULT_FIND; + name := cDEFAULT_NAME; + view := cDEFAULT_VIEW; + cur := cDEFAULT_CUR; + x := cDEFAULT_X; + y := cDEFAULT_Y; + w := cDEFAULT_W; + h := cDEFAULT_H; + end; + end; + + { + next proc unpacks string to objrec in following order : + pack:='[cVAR_VIEW:] [cVAR_CUR:] [cVAR_X:] ...'; + order of field is not valuable + such string will be unpacked in appropriate field of objrec + or defaults will be used. + } + procedure unpack_str(pack:string; var objrec:tobjrec); + var p:pdevice; + begin + with objrec do begin + w:=1; h:=1; view:=''; + if exists_var(cVAR_VIEW,pack) then view := get_var(cVAR_VIEW,pack); + if exists_var(cVAR_CUR ,pack) then cur := get_var(cVAR_CUR ,pack); + if exists_var(cVAR_X ,pack) then x :=toint(get_var(cVAR_X ,pack)); + if exists_var(cVAR_Y ,pack) then y :=toint(get_var(cVAR_Y ,pack)); + if exists_var(cVAR_W ,pack) then w :=toint(get_var(cVAR_W ,pack)); + if exists_var(cVAR_H ,pack) then h :=toint(get_var(cVAR_H ,pack)); + UpCaseStr(View); UpCaseStr(Cur); + if (w=1) and (h=1) and (view<>'') + then begin + if View='' then PlaySOund(sndClick); + p:=New(PDevice,Load(Res^.LoadRes(View)^)); + w:=p^.Width; + h:=p^.Height; + Dispose(P,done); + end; + end; + end; + { next proc packs objrec to string, + doing back operation to prev proc } + procedure pack_str(objrec:tobjrec; var s:string); + begin + with objrec do begin + add_var(cVAR_VIEW,view ,s); + add_var(cVAR_CUR ,cur ,s); + add_var(cVAR_X ,tostr(x),s); + add_var(cVAR_Y ,tostr(y),s); + add_var(cVAR_W ,tostr(w),s); + add_var(cVAR_H ,tostr(h),s); + end; + end; + + + { object class relation procedures and functions } + + { next proc extracts from class to objrec } + procedure class2objrec(Kind:pFlashObject; var objrec:tobjrec); + begin + new_objrec(objrec); + unpack_str(Kind^.reskey,objrec); + objrec.find:=Kind^.name; + objrec.name:=Kind^.playname; + end; + { + next proc extracts from dir(way_out) desc to objrec + dir=' '+pack + pack - is packed objrec + } + procedure dir2objrec(dir:string; var objrec:tobjrec); + begin + new_objrec(objrec); + unpack_str(dir,objrec); + objrec.find:=argument(dir,1); + objrec.name:=argument(dir,0); + end; + + + { next proc packs information from all objects in location in + one tlocrec } + procedure loc2locrec(loc:plocation; var locrec:tlocrec); + var a:integer; + begin + with locrec do begin + class2objrec(loc,self); + objcnt:=0; + for a:=0 to loc^.things^.count-1 do begin + if objcnt=cmaxobjects then begin + errorMSG(Str2PChar('In location '+loc^.name+' too many objects')); + exit; + end; + class2objrec(thinglist^.find(loc^.things^.get(a)),objrec[objcnt]); + inc(objcnt); + end; + for a:=0 to humanlist^.count-1 do if same(phuman(HUMANLIST^.get(a))^.place,LOC^.name) then begin + if objcnt=cmaxobjects then begin + errorMSG(Str2PChar('In location '+loc^.name+' too many objects')); + exit; + end; + class2objrec(humanlist^.get(a),objrec[objcnt]); + inc(objcnt); + end; + dircnt:=0; + for a:=0 to loc^.directions^.count-1 do begin + if objcnt=cmaxobjects then begin + errorMSG(Str2PCHar('In location '+loc^.name+' too many dirs')); + exit; + end; + dir2objrec(loc^.directions^.get(a),dirrec[dircnt]); + inc(dircnt); + end; + end; + end; + + function is_dir(x,y:integer; var locrec:tlocrec):boolean; + var a:integer; + begin + for a:=0 to locrec.dircnt-1 do + if contains_objrec(x,y,locrec.dirrec[a]) + then begin + is_dir:=true; + exit; + end; + is_dir:=false; + end; + + function get_name(x,y:integer; var locrec:tlocrec):nstring; + var a:integer; + begin + get_name:=locrec.self.name; + for a:=0 to locrec.objcnt-1 do + if contains_objrec(x,y,locrec.objrec[a]) + then begin + get_name:=locrec.objrec[a].name; + exit; + end; + for a:=0 to locrec.dircnt-1 do + if contains_objrec(x,y,locrec.dirrec[a]) + then begin + get_name:=locrec.dirrec[a].name; + exit; + end; + end; + + function get_find(x,y:integer; var locrec:tlocrec):tstring; + var a:integer; + begin + get_find:=locrec.self.find; + for a:=0 to locrec.objcnt-1 do + if contains_objrec(x,y,locrec.objrec[a]) + then begin + get_find:=locrec.objrec[a].find; + exit; + end; + for a:=0 to locrec.dircnt-1 do + if contains_objrec(x,y,locrec.dirrec[a]) + then begin + get_find:=locrec.dirrec[a].find; + exit; + end; + end; + + function get_objrec(x,y:integer; var locrec:tlocrec; var objrec:tobjrec):boolean; + var a:integer; + begin + get_objrec:=false; new_objrec(objrec); + for a:=0 to locrec.objcnt-1 do + if contains_objrec(x,y,locrec.objrec[a]) + then begin + objrec:=locrec.objrec[a]; + get_objrec:=true; + exit; + end; + for a:=0 to locrec.dircnt-1 do + if contains_objrec(x,y,locrec.dirrec[a]) + then begin + objrec:=locrec.dirrec[a]; + get_objrec:=true; + exit; + end; + end; + + + procedure show_locrec(var locrec:tlocrec; screen:pdevice); + var a:integer; + begin + showingloc:=true; + show_objrec(locrec.self,screen); + showingloc:=false; + for a:=0 to locrec.objcnt-1 do show_objrec(locrec.objrec[a],screen); + for a:=0 to locrec.dircnt-1 do show_objrec(locrec.dirrec[a],screen); + end; + + procedure hide_find(find:tstring; var locrec:tlocrec; screen:pdevice); + var objrec:tobjrec; + begin + del_objrec(find,locrec,objrec); + hide_mouse; + hide_objrec(locrec,objrec,screen); + show_mouse; + end; + + procedure del_objrec(find:tstring; var locrec:tlocrec; var objrec:tobjrec); + var a,b:integer; + begin + for a:=0 to locrec.objcnt-1 do + if same(locrec.objrec[a].find,find) + then begin + objrec:=locrec.objrec[a]; + for b:=a+1 to locrec.objcnt-1 do + locrec.objrec[b-1]:=locrec.objrec[b]; + exit; + end; + for a:=0 to locrec.dircnt-1 do + if same(locrec.dirrec[a].find,find) + then begin + objrec:=locrec.dirrec[a]; + for b:=a+1 to locrec.dircnt-1 do + locrec.dirrec[b-1]:=locrec.dirrec[b]; + exit; + end; + end; + + +end. + + diff --git a/UNITS/FLASH/MENU.PAS b/UNITS/FLASH/MENU.PAS new file mode 100644 index 0000000..b458281 --- /dev/null +++ b/UNITS/FLASH/MENU.PAS @@ -0,0 +1,177 @@ +Unit Menu; + +interface +uses tpstr; + +const + cMaxMenuItems = 32; + cDescSize = 32; + cNameSize = 15; + cMenuitem = 'Menuitem'; + cAddMenu = 30; + cRectColor= 43; + cUndColor = 25; + cMenuTitle = 'Меню паpаметpов игpока'; + +type itemrec = record + Desc:String[cDescSize]; + ParName:String[cNameSize]; + end; + + itemlist = array[0..cMaxMenuItems-1] of itemrec; + + function unpack_arr(arr:PStringArr; var list:itemlist):integer; + procedure showitems(list:itemlist; size:integer); + +implementation + +uses data,misc,fx_mouse,fx_pens,fx_form,tpparam,flobjects,fx_init; + +{$I locrange} + + procedure unpack2rec(pack:string; var item:itemrec); + begin + item.desc:=argument(pack,0); + item.ParName:=argument(pack,1); + end; + + function unpack_arr(arr:PStringArr; var list:itemlist):integer; + var cmd:string; + pack:string; + i:integer; + listsize:integer; + begin + listsize:=0; + for i:=0 to arr^.count-1 do begin + + cmd:=Arr^.Get(i); + pack:=ArgTail(cmd); + cmd:=Argument(Cmd,0); + + if Same(cmd,cMenuItem) then begin + unpack2rec(pack,list[listsize]); + inc(listsize); + end; + end; + unpack_arr:=listsize; + end; + + function item_wid(var item:itemrec):word; + var param:PParam; + begin + param:=Player^.Params^.SearchRec(Item.ParName); + if param=nil + then item_wid:=LightFont^.lnWidth(Item.desc) + else item_wid:=LightFont^.lnWidth(Item.desc +' '+Param^.Value); + end; + + function list_maxwid(var list:itemlist; size:integer):word; + var i:integer; + Wid,TempW:Word; + begin + Wid:=0; + for i:=0 to Size-1 do + begin + TempW:=Item_wid(list[i]); + if TempW>Wid then Wid:=TempW; + end; + list_maxwid:=Wid; + end; + + function item_value(var item:itemrec):string; + var param:PParam; + begin + param:=Player^.Params^.SearchRec(Item.ParName); + if Param=nil + then item_value:='' + else item_value:=Param^.Value; + end; + + function menu_form:pform; + begin + menu_form:=make_form( Rnd_fr, + New(PConvertPen,Init(Palette^.GlassIndex)), + LightFont ); + end; + + procedure showitems(list:itemlist; size:integer); + var maxwid:word; + maxhgt:word; + tempy,x,y:word; + form:pform; + fr:pframe; + + i:integer; + value:string[cNAmeSize]; + vx,vy,vw,vh:integer; + p:pcolorpen; + cpen,cpen1:PConvertPen; + begin + form:=menu_form; + maxwid:=list_maxwid(list,size)+cADDMenu+form^.offsetx*2; + maxhgt:=(LightFont^.lnHeight+5)*(size+1)+form^.offsety*2+1; + if (MaxWidMaxWid + then LightFont^.Writelen(x,tempy,MaxWid-Form^.OffsetX*2,Screen,cMenuTitle) + else LightFont^.Writeln(x+(MaxWid-LightFont^.lnWidth(cMenuTitle)) div 2-Form^.OffsetX,tempy,Screen,cMenuTitle); + Screen^.HLinear( x+(MaxWid-LightFont^.lnWidth(cMenuTitle)) div 2-Form^.OffsetX, + tempY+LightFont^.lnHeight+2, + LightFont^.LnWidth(cMenuTitle),P); + show_mouse; + + tempy:=tempy+3+LightFont^.lnHeight+3; + + hide_mouse; + for i:=0 to Size-1 do begin + LightFont^.Writeln(x,tempy,Screen,list[i].desc); + + value:=(item_value(list[i])); + FormatStr(Value); + vw:=LightFont^.lnWidth(value)-1; + vh:=LightFont^.lnHeight; + vx:=x+MaxWid-4-vw-form^.offsetx*2; + vy:=tempy; + Screen^.Map(vx-1,vy-1,vx+vw,vy+vh,cpen1); + LightFont^.Writeln(vx,vy,Screen,Value); + if Value<>'' then begin + Screen^.Rectangle(vx-2,vy-2,vx+vw+1,vy+vh+1,cpen); + Screen^.Rectangle(vx-2,vy-2,vx+vw+1,vy+vh+1,cpen); + end; + {fr^.DrawAround(Screen,vx-1,vy-1,vx+vw,vy+vh);} + tempy:=tempy+LightFont^.lnHeight+5; + end; + show_mouse; + anyclick; + + hide_mouse; + form^.unshow; + Dispose(cpen1,done); + Dispose(cpen,done); + Dispose(p,done); + Dispose(fr,done); + Dispose(Form,Done); + show_mouse; + end; + +end. + + diff --git a/UNITS/FLASH/MISC.PAS b/UNITS/FLASH/MISC.PAS new file mode 100644 index 0000000..fbee269 --- /dev/null +++ b/UNITS/FLASH/MISC.PAS @@ -0,0 +1,390 @@ +Unit Misc; + +interface + + const + VAR_SPACY_CHAR1 =' '; + VAR_SPACY_CHAR2 =';'; + VAR_SPACY_CHAR3 ='/'; + VAR_SPACY_CHAR4 =','; + VAR_SPACY_CHAR5 ='|'; + +type + TPoint = object + X, Y: Integer; + end; + TRect=object + x,y,x1,y1:integer; + procedure assign(a,b,c,d:integer); + function contains(a,b:integer):boolean; + function equals(a,b,c,d:integer):boolean; + end; + + bytearr=array[0..65000] of byte; + fstring=string[8]; + function altx_pressed:boolean; + function PressedFunc(Num:Byte):boolean; +function Esc_pressed:boolean; + + procedure loggy(filename:fstring; logstr:string); + + function exists_var(varname:string; s:string):boolean; + function get_var(varname:string; s:string):string; + procedure add_var(varname,value:string; var s:string); + + function testbit(bitnum:byte; inbyte:byte):boolean; + function toBINARY(b:byte):string; + function leftscroll(b:byte; cnt:byte):byte; + function rightscroll(b:byte; cnt:byte):byte; + + function belongs(x,Minx,Maxx:longint):boolean; + function tostr(a:longint):string; + function dup(a:byte;ch:char):string; + +function PtrTOStr(Ptr:pointer):string; +procedure tabto(pos:byte; ch:char); +function Str2PChar(s:string):PChar; + function RestString(Str:String):String; + + Procedure Beep ; + Procedure Music ; + procedure sound(Hz:word); + procedure voice(hz,ms:word); + Procedure Delay(MS:Word); + Procedure VideoMode (Mode : byte) ; + Procedure InitVGAMode ; + Procedure InitTextMode ; + Function KeyPressed : Boolean ; + Function ReadKey : Char ; + Procedure ClearKBD ; + +procedure WVStart; +procedure WVEnd; + +implementation +Uses tpstr,swset,core,gr_err,tpdos,strings,crt; + + function RestString(Str:String):String; + begin + if Arguments(Str)<>0 + then RestString:=Copy(Str,Pos(' ',Str)+1,255) + else RestString:=''; + end; +function Esc_pressed:boolean; +begin + Esc_pressed:=keypressed and (ReadKey=#27); +end; +function PressedFunc(Num:Byte):boolean; +begin + PressedFunc:= Keypressed and (ReadKey=#0) and + Keypressed and (ReadKey=Chr(58+Num)); +end; + +function dup; + var b:integer; + s:string; +begin + s:=''; + for b:=1 to a do s:=s+ch; + dup:=s; +end; + +procedure clearbuff; +begin + if keypressed then Readkey; +end; +function Belongs; +begin + if (x>=Minx) and (x<=Maxx) then Belongs:=true else Belongs:=false; +end; +function tostr(a:longint):string; +var s:string; +begin + str(a,s); + tostr:=s; +end; + + Const + MCh: Byte=0; + + Procedure SpeakerOn (toneout : word) ; Assembler ; + asm + mov al, 182 { prepare timer to start generating sound } + out 43h, al + mov ax, toneout { TONEOUT = word: 1193180 / frequency } + out 42h, al { send low byte to port 42h } + mov al, ah + out 42h, al { send high byte to port 42h } + in al, 61h { get current value of port 61h } + or al, 3 { set lowest two bits of 61h "on" -- activate speaker } + out 61h, al { rewrite to port 61h } + end; + + Procedure SpeakerOff ; Assembler ; + asm + in al, 61h { set lowest two bits of 61h "off" -- deactive speaker } + and al, 252 { this line turns the lowest two bits "off" } + out 61h, al + end; + + Procedure Beep ; + Begin + if SoundEnabled then begin + SpeakerOn (800) ; + delay(3); + SpeakerOff ; + end; + End ; + + Procedure Music ; + Begin + SpeakerOn (1600) ; + delay (3) ; + SpeakerOn (1700) ; + delay (3) ; + SpeakerOn (1500) ; + delay (3) ; + SpeakerOn (1600) ; + delay (3) ; + SpeakerOn (1700) ; + delay (3) ; + SpeakerOff ; + End ; + + Procedure VideoMode ( Mode : Byte ); + Begin { VideoMode } + Asm + Mov AH,00 + Mov AL,Mode + Int 10h + End; + End; { VideoMode } + + Procedure InitVGAMode ; + Begin + VideoMode (19) ; + gr_err.set_gr_io; + End ; + + Procedure InitTextMode ; + Begin + VideoMode (03) ; + core.defaultio; + End ; + + function altx_pressed:boolean; +begin + altx_pressed:= + keypressed and + (ord(readkey)=00) and + keypressed and + (ord(readkey)=45) ; +end; + + + Function ReadKey ; Assembler; + Asm + mov al,MCh + mov byte ptr MCh,00 + or al,al + jne @0338 + xor ah,ah + int 16h + or al,al + jne @0338 + mov MCh,ah + or ah,ah + jne @0338 + mov al,03h + @0338: + End; + + Function KeyPressed ; Assembler; + Asm + cmp byte ptr MCh,00 + jne @0317 + mov ah,01h + int 16h + mov al,00h + je @0319 + @0317: + mov al,01h + @0319: + End; + + Procedure ClearKBD ; Assembler; + Asm + @@Begin: + mov ah,01h + int 16h + je @@Exit + xor ah,ah + int 16h + jmp @@Begin + @@Exit: + End; + procedure Delay; + begin + crt.delay(ms); + end; + +procedure WVStart; +assembler; asm + push ax + push dx + + mov dx, 03dah +@@11: + in al,dx + test al,08h + jnz @@11 +@@22: + in al,dx + test al,08h + jz @@22 + + pop dx + pop ax +END; + + +procedure WVEnd; +assembler; asm + + pusha + + mov dx,03dah +@@33: + in al,dx + test al,08h + jz @@33 +@@44: + in al,dx + test al,08h + jnz @@44 + + popa + ret +END; + +function PtrTOStr(Ptr:pointer):string; +begin + if not assigned(Ptr) + then PtrTOStr:='nil' + else PtrTOStr:=TOStr(Seg(Ptr^))+':'+ToStr(Ofs(Ptr^)); +end; + + procedure sound; + begin + crt.sound(hz); + end; + procedure voice; + begin + crt.sound(hz); + delay(ms); + crt.nosound; + end; + + procedure tabto(pos:byte; ch:char); + begin + if wherexpos do write(ch); + end; + + function testbit(bitnum:byte; inbyte:byte):boolean; + assembler; asm + mov al,inbyte + mov cl,bitnum + shr al,cl + shl al,7 + shr al,7 + end; + + function toBINARY(b:byte):string; + var a:byte; + s:string[8]; + begin + s:=''; + for a:=0 to 7 do + if testbit(a,b) then s:=concat('1',s) else s:=concat('0',s); + toBINARY:=s+'b'; + end; +function leftscroll(b:byte; cnt:byte):byte; +assembler; asm + mov al,b + mov cl,cnt + rol al,cl +end; +function rightscroll(b:byte; cnt:byte):byte; +assembler; asm + mov al,b + mov cl,cnt + ror al,cl +end; + procedure loggy(filename:fstring; logstr:string); + var f:text; + begin + assign(f,filename+'.log'); + + if existfile(filename+'.log') + then Append(f) else Rewrite(f); + + writeln(f,logstr); + close(f); + end; + function space_char(ch:char):boolean; + begin + space_char:= (ch=VAR_SPACY_CHAR1) or + (ch=VAR_SPACY_CHAR2) or + (ch=VAR_SPACY_CHAR3) or + (ch=VAR_SPACY_CHAR4) or + (ch=VAR_SPACY_CHAR5); + end; + + function get_var(varname:string; s:string):string; + var a,b:byte; + + begin + b:=pos(varname+':',s); + if b<>0 then begin + for a:=b+length(varname)+1 to length(s) do if space_char(s[a]) then break; + if (not space_char(s[length(s)])) and (a=length(s)) then a:=a+1; + get_var:=copy(s,b+length(varname)+1,a-b-length(varname)-1) + end else get_var:=''; + end; + function exists_var(varname:string; s:string):boolean; + begin + exists_var:=(pos(varname+':',s)<>0); + end; + procedure add_var(varname,value:string; var s:string); + var a:byte; + begin + if not exists_var(varname,s) + then s:=s+varname+':'+value+VAR_SPACY_CHAR1 + else begin + for a:=pos(varname+':',s)+1 to length(s) do + if space_char(s[a]) then exit; + s:=copy(s,1,pos(varname+':',s)) + varname+':'+value + copy(s,a,255); + end; + end; + + procedure trect.assign; + begin + x:=a; y:=b; x1:=c; y1:=d; + end; + function trect.contains; + begin + contains:= belongs(a,x,x1) and + belongs(b,y,y1); + end; + function trect.equals; + begin + equals:=(x=a) and (y=b) and (x1=c) and (y1=d); + end; +function Str2PChar(s:string):PChar; + var p:Pointer; +begin + GetMem(p,Length(s)+1); + Str2PCHar:=StrPCopy(p,S); +end; +end. diff --git a/UNITS/FLASH/PLAY.PAS b/UNITS/FLASH/PLAY.PAS new file mode 100644 index 0000000..0bbf188 --- /dev/null +++ b/UNITS/FLASH/PLAY.PAS @@ -0,0 +1,53 @@ +Unit Play; + +interface + + procedure PlaySound(Name:string); + procedure WaitSound; + procedure SoundInit; + procedure SoundDone; + +implementation + + Uses Core,Objects,SWSet,Sound,Audio; + + Var Device :PStreamBlaster; + Data :PDosStream; + List :PSoundList; + WasEnabled:boolean; + procedure PlaySound(Name:string); + begin + if SoundEnabled and (not Device^.Playing) then List^.Play(Name,Device^); + end; + procedure WaitSound; + begin + if SoundEnabled + then While Device^.Playing do ; + end; + + procedure SoundInit; + var idx:PDosStream; + begin + if SoundEnabled then begin + New(Data,init(SoundFile,stOpenRead)); + If Data^.Status<>stOk then FatalMSG('Error opening sound file'); + New(Idx,Init(IndexFile,stOpenRead)); + If Idx^.Status<>stOk then FatalMSG('Error opening index file'); + New(List,Load(Idx^)); + Dispose(Idx,done); + New(Device,init(SB_Port,SB_Irq,SB_DMA,Data)); + WasEnabled:=True; + end else WasEnabled:=False; + end; + procedure SoundDone; + begin + if WasEnabled then begin + Device^.WaitPlayed; + Dispose(List,Done); + Dispose(Data,Done); + Dispose(Device,Done); + end; + end; + + begin + end. diff --git a/UNITS/FLASH/RES_TYPE.PAS b/UNITS/FLASH/RES_TYPE.PAS new file mode 100644 index 0000000..16b176f --- /dev/null +++ b/UNITS/FLASH/RES_TYPE.PAS @@ -0,0 +1,127 @@ +Unit Res_type; +{$I stdefine.inc} +{$DEFINE NOPACK} +interface + +uses objects; + +type + pobject_space=^tobject_space; + tobject_space=object(TObject) + _stream:pstream; + constructor init(usestream:pstream); + destructor done; virtual; + function stream:pstream; + constructor load(var s:tstream); + procedure store(var s:tstream); + end; +type + pres_file=^tres_file; + tres_file=object(tobject) + resfile:presourcefile; + space:pobject_space; + constructor init(filename:string; fmode,lmode:word); + destructor done; virtual; + function loadres(resname:string):pstream; + procedure storeres(resname:string;var stream:tstream); + procedure put_file(filename:string; resname:string); + end; + +implementation + +Uses streams,kernel,misc,core,tpdos; + +const + robject_space:tstreamrec=( + objtype:9851; + VMTLink:ofs(TypeOF(tobject_space)^); + Load: @tobject_space.load; + Store: @tobject_space.store ); + + constructor tobject_space.init; + begin + tobject.init; + _stream:=usestream; +{ _stream^.seek(0); + _stream^.truncate;} + end; + destructor tobject_space.done; + begin + if _stream<>nil then dispose(_stream,done); + tobject.done; + end; + function tobject_space.stream; + begin + stream:=_stream; + end; + constructor tobject_space.load; + var asize:longint; + begin + {$IFDEF DPMI} + Init(New(PRAMStream,Init(64*1024-10))); + {$ELSE} + Init(New(PXMSStream,Init(1024,1024))); + {$ENDIF} + S.Read(asize,sizeof(asize)); + _stream^.seek(0); _stream^.truncate; + stream^.copyfrom(s,asize); + _stream^.seek(0); + end; + procedure tobject_space.store; + var asize:longint; + begin + asize:=_stream^.getsize; + S.Write(asize,sizeof(asize)); + _stream^.seek(0); + S.CopyFrom(_stream^,asize); + _stream^.seek(0); + end; + procedure tres_file.storeres; + begin + if space<>nil then dispose(space,done); + new(space,init(@stream)); + resfile^.put(space,resname); + space^._stream:=nil; + dispose(space,done); + space:=nil; + end; + constructor tres_file.init; + begin + tobject.init; + {$IFDEF NOPACK} + new(resfile,init(new(pdosstream,init(filename,fmode)))); + {$ELSE} + new(resfile,init(new(plzwfilter,init(new(pbufstream,init(filename,fmode,1024)),lmode)))); + {$ENDIF} + space:=nil; + end; + destructor tres_file.done; + begin + dispose(resfile,done); + if space<>nil + then dispose(space,done); + end; + function tres_file.loadres; + begin + loadres:=nil; + if space<>nil then dispose(space,done); + space:=pobject_space(resfile^.get(resname)); + if space=nil + then fatalMSG(Str2Pchar('Can`t find such res - '+resname)) + else loadres:=space^.stream; + end; + + procedure tres_file.put_file; + var f:pdosstream; + begin + if existfile(filename) + then begin + new(f,init(filename,stOpenRead)); + storeres(resname,f^); + dispose(f,done); + end else errorMSG(Str2PChar('can`t find file '+filename+' to pack in res-file')); + end; + +begin + RegisterType(robject_space); +end. \ No newline at end of file diff --git a/UNITS/FLASH/SOUND.PAS b/UNITS/FLASH/SOUND.PAS new file mode 100644 index 0000000..93a1d4c --- /dev/null +++ b/UNITS/FLASH/SOUND.PAS @@ -0,0 +1,157 @@ +Unit Sound; + interface + uses objects,audio; + + Type PStreamBlaster = ^TStreamBlaster; + TStreamBlaster = object(SoundBlasterPro) + SoundStream : PStream; + Playing : boolean; + Rest : Longint; + constructor Init(Port,Irq,Dma:word; Stream:PStream); + procedure PlaySound(Pos,Size:Longint; Rate:Word); + Procedure OutBuffer (Var Buffer; Size : Word); Virtual; + Procedure InBuffer (Var Buffer; Size : Word); Virtual; + Procedure RecordingReady; Virtual; + Procedure PlaybackReady; Virtual; + procedure WaitPlayed; + end; + + Type PSound = ^TSound; + TSound = object(TObject) + Name : String[16]; + Pos : Longint; + Size : Longint; + Rate : word; + end; + + PSoundList = ^TSoundList; + TSoundList = object(TCollection) + procedure Put(Sound:PSound); + function Get(i:integer):PSound; + constructor Load(Var S:TStream); + procedure Store(Var S:TStream); + function Find(name:string):PSOund; + procedure LinkSound(FileName,Identifier:string;Rate:Word; var Data:TStream); + procedure Play(Sound:string; Var Device:TStreamBlaster); + end; + + implementation + uses tpstr; + + procedure TSoundList.Play; + var Snd:PSound; + begin + Snd:=Find(Sound); + If Snd<>nil + then begin + Device.PlaySound(Snd^.Pos,Snd^.Size,Snd^.Rate); + end; + end; + procedure TSoundList.LinkSound; + var F:PDosStream; + p:PSound; + begin + New(F,Init(Filename,StOpenRead)); + if F^.Status<>StOk + then Writeln('Can`t link - file not found') + else begin + new(p,init); + p^.Name:=Identifier; + p^.pos:=Data.GetPos; + p^.size:=f^.getsize; + p^.rate:=rate; + data.copyfrom(f^,f^.getsize); + Put(p); + end; + end; + function TSoundList.Find; + var a:integer; + begin + Find:=Nil; + for a:=0 to Count-1 do + if Same(Name,Get(a)^.Name) + then begin + Find:=Get(a); + Exit; + end; + end; + procedure TSoundList.Store; + var Size:Word; + a: integer; + begin + Size:=Count; + S.Write(Size,Sizeof(Size)); + for a:=0 to Count-1 do with get(a)^ do begin + PutString(Name,S); + S.Write(Pos,Sizeof(Pos)); + S.Write(Size,Sizeof(Size)); + S.Write(Rate,Sizeof(Rate)); + end; + end; + constructor TSoundList.Load; + var i,a:integer; + p:PSound; + begin + inherited init(1,1); + S.Read(a,sizeof(word)); + for i:=0 to a-1 do begin + new(p,init); + with P^ do begin + name:=getstring(s); + S.read(Pos,Sizeof(Pos)); + S.read(Size,Sizeof(Size)); + S.read(Rate,Sizeof(Rate)); + end; + put(p); + end; + end; + procedure TSoundList.put; + begin + Insert(Sound); + end; + function TSoundList.get; + begin + get:=At(i); + end; + +procedure TStreamBlaster.WaitPlayed; +begin + While Playing do ; +end; +procedure TStreamBlaster.Outbuffer; +begin + Abstract; +end; +procedure TStreamBlaster.RecordingReady; +begin + Abstract; +end; +procedure TStreamBlaster.InBuffer; +begin + SoundStream^.Read(Buffer,Size); +end; +procedure TStreamBlaster.PlaybackReady; +begin + SetVolume(Master,LeftAndRight,1); + Playing:=False; +end; +constructor TStreamBlaster.Init; +begin + inherited init(Port,Irq,Dma); + SetVolume(MicroPhone,LeftAndRight,1); + SoundStream:=Stream; + Playing:=False; +end; +procedure TStreamBlaster.PlaySound; +begin + If (Posnil then Exit; + new(statusdata.store,init(cStatus.w,cStatus.H)); + statusdata.line:=''; + hide_mouse; + screen^.partdevicecopy(0,0,cStatus.x,cStatus.y,cStatus.w,cStatus.h,statusdata.store); + show_mouse; +end; +procedure done_status; +begin + If StatusData.Store=Nil then Exit; + dispose(statusdata.store,done); + Statusdata.store:=nil; +end; + +function dostatus(line:string):pdevice; + var p:pdevice; + mlen:integer; + s:word; +begin + asm + mov s,si + end; + + {$IFDEF MEMSTAT} + line:= 'SI='+tostr(s)+' HEAP='+tostr(memavail)+' XMS='+tostr(xms_memavail)+ + ' EMS='+tostr(ems_memavail); + {$ENDIF} + + new(p,init(cStatus.w,cStatus.h)); + statusdata.store^.fulldevicecopy(0,0,p); + mlen:=(cStatus.w - LightFont^.lnWidth(line)) div 2; + if mlen<0 then mlen:=0; + LightFont^.Writelen( mlen,(cStatus.h - LightFont^.lnHeight) div 2, + cStatus.w, p, Line ); + dostatus:=p; +end; + +procedure statusline(cx,cy:word); + var p:pdevice; + name:string; + +begin + name:=''; + if cVIEW.contains(cx,cy) + then name:=get_name(cx,cy,loc_id) + else if in_buttons(cx,cy) + then name:=buttons_text(cx,cy) + else if cDREAMS.contains(cx,cy) + then name:='Пpезентация этой игpы' + else if cWIZECORE.contains(cx,cy) + then name:='О создателях игpы' + else if in_thingbar(cx,cy) then begin + name:=name_thingbar(cx,cy); + if findin(name)=nil + then name:='' + else name:=findin(name)^.playname; + end; + + if name<>statusdata.line + then begin + hide_mouse; + p:=dostatus(name); + p^.fulldevicecopy(cStatus.x,cStatus.y,screen); + dispose(p,done); + show_mouse; + statusdata.line:=name; + end; +end; + +procedure string2status(name:string); + var p:pdevice; +begin + p:=dostatus(name); + p^.fulldevicecopy(cStatus.x,cStatus.y,screen); + dispose(p,done); +end; + +begin + Statusdata.store:=nil; + Statusdata.line:='Dummy status line'; +end. diff --git a/UNITS/FLASH/STRCONST.PAS b/UNITS/FLASH/STRCONST.PAS new file mode 100644 index 0000000..1ded896 --- /dev/null +++ b/UNITS/FLASH/STRCONST.PAS @@ -0,0 +1,30 @@ +Unit strConst; +{ string constants definition } +Interface +Const + cScenario ='dreams'; + cVersion =' Version '; + cCopyright =' Copyright (C) '; + cConfSwitches ='configured switches: '; + cPlayMode ='playmode='; + cDebugPlay =' debugplay='; + cAllocate ='allocating under script '; + cBytes =' bytes'; + + cLocTitle ='Location'; + cDescribeAct ='describe'; + cNoTHINGS ='There is no things'; + cTHingThere ='Things there:'; + cNoVisibleOuts ='There is no visible outs'; + cOutsHere ='Outs from here:'; + cNoHumans ='There is no humans'; + cHumansHere ='Humans here'; + cNoSuchOut ='There is no such out'; + cPlayModeOn ='Play mode turned on'; + cYes ='Yes'; + + cCantConvertID ='Can`t convert(str->classid):'; + + +implementation +end. \ No newline at end of file diff --git a/UNITS/FLASH/SWSET.PAS b/UNITS/FLASH/SWSET.PAS new file mode 100644 index 0000000..08a5523 --- /dev/null +++ b/UNITS/FLASH/SWSET.PAS @@ -0,0 +1,118 @@ +Unit SwSet; +interface + + uses paths; + +const + DebugMode:boolean = true; + ShowLoadObjects:boolean = true; + DynamicExit:boolean = true; + SoundEnabled:boolean = false; + CloseStandartIO:boolean = false; + DoStartChecking:boolean = true; + DoFading:boolean = false; + ShowMovie:boolean = false; + DoProcessBar:boolean = true; + DoItemBar:boolean = false; + DoLogOut:boolean = false; + DoSysCheck:boolean = true; + + SB_Port :word = $220; + SB_Irq :word = 7; + SB_Dma :word = 1; + + ResourceFile :string[79] = cResourcePath+'resource.dat'; + ScriptFile :string[79] = cScriptPath+'dreams.dat'; + SoundFile :string[79] = cSoundPath+'sound.dat'; + IndexFile :string[79] = cSoundPath+'sound.idx'; + +implementation + +uses tpstring,misc,tpstr,core,start; + + function ExistSwitch(S:String):boolean; + var i:integer; + begin + ExistSwitch:=false; + for i:=1 to ParamCount do begin + If Same(ParamStr(i),'-'+S) or + Same(ParamStr(i),'/'+S) + then ExistSwitch:=true; + end; + end; + + function ExistFile(S:String):String; + var i:integer; + begin + ExistFile:=''; + for i:=1 to ParamCount do begin + If Same(Copy(ParamStr(i),1,1+Length(S)),'-'+S) or + Same(Copy(ParamStr(i),1,1+Length(S)),'/'+S) + then ExistFile:=Copy(ParamStr(i),2+Length(S),255); + end; + end; + +begin + if ExistSwitch('?') or + ExistSwitch('help') + then begin + Writeln; + Writeln('Эхо снов(Dreams) от WIZECORE 1995,96 год.'); + Writeln; + Writeln(' возможные паpаметpы в командной стpоке:'); + Writeln(' вместо символа "-" может быть "/"'); + Writeln(' -n - использовать SoundBlaster Pro'); + Writeln(' -d - выход с помощью DOS'); + Writeln(' -c - закpывать стандаpтные файлы'); + writeln(' -t - не тестиpовать пpи запyске'); + Writeln(' -f - плавно гасить экpан'); + Writeln(' -m - показывать мyльтипликацию'); + Writeln(' -b - не показывать пpоцесс загpyзки'); + Writeln(' -l - записывать в лог-файл пpоцесс загpyзки'); + Writeln(' -i - не показывать пpоцесс обpаботки об`ектов'); + Writeln(' -irq - Interrupt for SB Pro'); + Writeln(' -dma - DMA Channel for SB Pro'); + Writeln(' -r - пyть и имя pесypс-файла'); + Writeln(' -s