Crawly Crypt Collection 2

home *** CD-ROM | disk | FTP | other *** search

/ Crawly Crypt Collection 2 / crawlyvol2.bin / apps / database / hypergem / hypergem.lst < prev next >

Wrap

File List | 1994-09-02 | 84KB | 2,610 lines

' TITLE : Hierarchical Database ' BY : Timothy Raine ' VERSION : 1.1 ' DATE : 30th May 1994 ' --------------------------------- ' $m600000 ! Reserve Program Memory RESERVE 600000 GOSUB start_up GOSUB main_routine GOSUB close_down ' > PROCEDURE start_up ' General Initialisation ' ------------------------ VOID FRE(0) ! Memory Garbage Collection ON ERROR GOSUB close_down ! Trap Errors ~APPL_INIT() ! Announce Application ~WIND_GET(0,4,scrx%,scry%,scrb%,scrh%) ! Max screen size GOSUB get_textsize(chrb%,chrh%,chrbb%,chrbh%) ! System Font Size GRAPHMODE 0 ! Set Graphics Mode DEFFILL ,0 ! Set Fill Pattern ' Call Initialisation Routines ' ------------------------------ LET path$=CHR$(GEMDOS(25)+65)+":"+DIR$(0)+"\" ! Current File Directory GOSUB load_resource(path$) ! Load Resource File GOSUB load_mouse(path$) ! Load Mouse Shapes GOSUB define_cursor ! Define Cursor Shape GOSUB define_datastructure ! Define Datastructure GOSUB reset_datastructure ! Reset Datastructure GOSUB hypergem_info ! Load Info Graphic GOSUB init_menu ! Define Menu Bar GOSUB init_bitblt ! Initialise BitBlt GOSUB init_sample ! Initialise Sample RETURN ' > PROCEDURE close_down ' PURPOSE : Closes any open windows, removes menu bar, ' frees reserved memory used for resource file ' and alerts the user if an error occurred. IF ERR<>0 ALERT 1,"CLOSING HYPERSYSTEM DOWN!|"+ERR$(ERR),1," Ok! ",void% ENDIF MENU KILL GOSUB close_old(handle&) ~RSRC_FREE() ! Free reserved memory ~APPL_EXIT() ! Close Application EDIT ! Return to editor RETURN ! Dummy Return ' ' ' SECTION : Resource File, Mouse & Cursor Definitions ' ----------------------------------------------------- ' > PROCEDURE load_resource(path$) ' PURPOSE : Load resource file & tree objects. ' ' PARAMS : (path$) Default file path from which system was loaded. ' LOCAL tree% IF EXIST(path$+"HYPERGEM.RSC") ! Found Resource File? ~RSRC_LOAD(path$+"HYPERGEM.RSC") ! YES, Load Resource File ~RSRC_GADDR(0,1,tree%) ! Returns address of 2nd Object CHAR{{OB_SPEC(tree%,3)}}="Next Window" ! Sets input string of object to "Next Window" ELSE ! Else Error Alert User! ALERT 1,"RESOURCE FILE NOT FOUND!|Please, locate the file called:|filename: HYPERGEM.RSC",1," OK! ",void% GOSUB close_down ! Close down system. ENDIF RETURN ' > PROCEDURE load_mouse(path$) ' PURPOSE : Load Mouse Definitions for file operations (floppy disk), ' Fill colour table (paintcan) and draw graphic (pencil) ' ' PARAMS : (path$) Default file path from which system was loaded. ' IF EXIST(path$+"LOADSAVE.DAT") AND EXIST(path$+"PAINTCAN.DAT") AND EXIST(path$+"PENCIL.DAT") LET iomouse$=STRING$(74,0) ! YES, allocate Memory BLOAD path$+"LOADSAVE.DAT",VARPTR(iomouse$) ! Load Definition File LET paintcan$=STRING$(74,0) ! Allocate Memory BLOAD path$+"PAINTCAN.DAT",VARPTR(paintcan$)! Load Definition File LET pencil$=STRING$(74,0) ! Allocate Memory BLOAD path$+"PENCIL.DAT",VARPTR(pencil$) ! Load Definition File ELSE ! Else Error Alert User! ALERT 1,"MOUSE SHAPE FILES NOT FOUND!|Please, locate files called:|'LOADSAVE.DAT', 'PAINTCAN.DAT'|and 'PENCIL.DAT'",1," OK! ",void% GOSUB close_down ! Close down system nicely. ENDIF RETURN ' > PROCEDURE define_cursor ' PURPOSE : Define cursor shape as underscore character sprite. ' (see manual for further details.) ' LOCAL loop% LET cursor$=MKI$(0)+MKI$(0)+MKI$(0)+MKI$(0)+MKI$(1) FOR loop%=0 TO 28 LET cursor$=cursor$+MKI$(0) NEXT loop% LET cursor$=cursor$+MKI$(65280)+MKI$(65280)+MKI$(65280) RETURN ' ' ' SECTION : Define & Reset Datastructure ' ---------------------------------------- ' > PROCEDURE define_datastructure ' PURPOSE : Main data structure for storing information on window ' size and contents. It also stores data about buttons ' and window link details. ' DIM xpos%(255),ypos%(255),wsiz%(255),hsiz%(255),hpos%(255),vpos%(255) DIM crea_date$(255),crea_time$(255),type$(255),file$(255),tail%(255) DIM xbut%(255,25),ybut%(255,25),desc$(255,25),head%(255,25),txt$(4000) RETURN ' > PROCEDURE reset_datastructure ' PURPOSE : Initialises main datastructure to default values. ' LOCAL loop%,i% FOR loop%=1 TO 255 LET xpos%(loop%)=50 ! Default window X position. LET ypos%(loop%)=50 ! Default window Y position. LET wsiz%(loop%)=150 ! Default window width. LET hsiz%(loop%)=150 ! Default window height. LET hpos%(loop%)=0 ! Horizonal slider position. LET vpos%(loop%)=0 ! Vertical slider position. LET tail%(loop%)=0 ! Pointer to previous window LET crea_date$(loop%)=DATE$ ! Get current date. LET crea_time$(loop%)=TIME$ ! Get current time. LET type$(loop%)="" ! Window type. LET file$(loop%)="FILENAME.TXT" ! Filename of window contents. FOR i%=1 TO 25 LET xbut%(loop%,i%)=0 ! Button x position. LET ybut%(loop%,i%)=0 ! Button y position. LET head%(loop%,i%)=0 ! pointer to next window. LET desc$(loop%,i%)="" ! button description. NEXT i% NEXT loop% RETURN ' ' ' SECTION : Initialise Menu Bar ' ------------------------------- ' > PROCEDURE init_menu ' PURPOSE : drop down menu definition and creation. ' LOCAL loop% DIM m$(50) ! array to hold menu information RESTORE menu FOR loop%=0 TO 24 READ m$(loop%) NEXT loop% DEFMOUSE 0 MENU m$() MENU 13,2 ! Run HyperSystem MENU 16,2 ! Save HyperSystem MENU 21,2 ! Add Button MENU 22,2 ! Modify Button MENU 23,2 ! Erase Button GOSUB loading_message menu: DATA Desk DATA Information on HyperGEM ◆I DATA ----------------------------- DATA 1 DATA 2 DATA 3 DATA 4 DATA 5 DATA 6 DATA DATA File DATA Generate HyperSystem ◆G DATA -------------------------- DATA Run HyperSystem ◆R DATA -------------------------- DATA Load HyperSystem ◆L DATA Save HyperSystem ◆S DATA -------------------------- DATA Quit Program ◆Q DATA DATA Window DATA Add Button ◆A DATA Modify Button ◆M DATA Erase Button ◆E DATA RETURN ' > PROCEDURE loading_message ' PURPOSE : Displaying HyperGEM Dialogue Message. ' LOCAL tree%,dx%,dy%,dw%,dh% DEFMOUSE 2 ~FORM_DIAL(3,scrx%,scry%,scrb%,scrh%,scrx%,scry%,scrb%,scrh%) ~RSRC_GADDR(0,3,tree%) ~FORM_CENTER(tree%,dx%,dy%,dw%,dh%) ~GRAF_SHRINKBOX(dx%,dy%,dw%,dh%,scrx%,scry%,scrb%,scrh%) ~FORM_DIAL(0,dx%,dy%,dw%,dh%,dx%,dy%,dw%,dh%) ~OBJC_DRAW(tree%,0,3,dx%,dy%,dw%,dh%) GOSUB init_dither_matrix GOSUB init_dither_array ~FORM_DIAL(3,dx%,dy%,dw%,dh%,dx%,dy%,dw%,dh%) ~GRAF_GROWBOX(dx%,dy%,dw%,dh%,scrx%,scry%,scrb%,scrh%) DEFMOUSE 0 RETURN ' ' ' SECTION : Initialise Colour Dithering Arrays ' ---------------------------------------------- ' > PROCEDURE init_dither_matrix ' PURPOSE : Initialising Ordered Dithering Array. ' LOCAL y%,x% DIM col|(16),dither|(3,3) RESTORE graphics FOR y%=0 TO 3 FOR x%=0 TO 3 READ dither|(x%,y%) NEXT x% NEXT y% ' colour dithering matrix data graphics: DATA 1, 9, 3,11 DATA 13, 5,15, 7 DATA 4,12, 2,10 DATA 16, 8,14, 6 RETURN ' > PROCEDURE init_dither_array ' PURPOSE : Initialising Colour Conversion Array ' LOCAL z%,y%,x% DIM dither2|(64000),pic|(64000) ! for colour conversion LET z%=1 FOR y%=1 TO 200 FOR x%=1 TO 320 LET dither2|(z%)=dither|(x% MOD 4,y% MOD 4) INC z% NEXT x% NEXT y% RETURN ' ' ' SECTION : Initialise Bitblt Array & Sample Routines ' ----------------------------------------------------- ' > PROCEDURE init_bitblt ' PURPOSE : Initialise BitBlt Array ' DIM smfdb%(8),dmfdb%(8),p%(8) ! for bitblt routine LET dmfdb%(0)=XBIOS(3) LET dmfdb%(1)=640 ! screen horizontal resolution LET dmfdb%(2)=400 ! screen vertical resolution LET dmfdb%(3)=40 ! screen width in words LET dmfdb%(5)=1 ! screen number of bit planes LET smfdb%(1)=640 ! raster horizontal resolution LET smfdb%(2)=400 ! raster vertical resolution LET smfdb%(3)=40 ! screen width in words LET smfdb%(5)=1 ! raster number of bit planes LET raster$=STRING$(32000,0) ! fill arrays with blanks RETURN ' > PROCEDURE init_sample ' PURPOSE : Initialise DVSM playback frequency array ' LOCAL loop% DIM freq%(7) ! array to hold frequency information RESTORE sample FOR loop%=0 TO 7 READ freq%(loop%) NEXT loop% sample: DATA 8195,9834,12292,16490,20770,24585,33880,49170 RETURN ' ' ' SECTION : Drop Down Menu Management Procedures ' ------------------------------------------------ ' > PROCEDURE main_routine ' PURPOSE : Wait for window, menu and keyboard events. ' ON MENU MESSAGE GOSUB message ON MENU GOSUB evaluate_menu ON MENU KEY GOSUB keyboard DO ON MENU 1000 LOOP RETURN ' > PROCEDURE evaluate_menu ' PURPOSE : gets menu selection result and branches to appropriate ' menu option procedure. ' MENU OFF ! Disables anymore menu events. IF m$(MENU(0))=" Information on HyperGEM ◆I" GOSUB display_dialog_box ELSE IF m$(MENU(0))=" Generate HyperSystem ◆G" GOSUB generate_hypersystem ELSE IF m$(MENU(0))=" Run HyperSystem ◆R" GOSUB run_hypertext ELSE IF m$(MENU(0))=" Load HyperSystem ◆L" GOSUB load_hypertext ELSE IF m$(MENU(0))=" Save HyperSystem ◆S" GOSUB save_hypertext ELSE IF m$(MENU(0))=" Quit Program ◆Q" GOSUB quit_program ELSE IF m$(MENU(0))=" Add Button ◆A" GOSUB add_button ELSE IF m$(MENU(0))=" Modify Button ◆M" GOSUB find_button_modify ELSE IF m$(MENU(0))=" Erase Button ◆E" GOSUB erase_button ENDIF RETURN ' > PROCEDURE file_select(title$,filetype$,save!) ' PURPOSE : Provides the user with a file selector box to choose the file ' on which he wants to save or load. ' SPRITE cursor$ REPEAT FILESELECT #title$,path$+filetype$,"",filename$ IF EXIST(filename$) ! does file exist LET extender$=RIGHT$(filename$,3) ! NOTE: file extension ELSE IF filename$<>"" ! file NOT found IF save!=TRUE ALERT 1,"File does not exist|"+filename$+"!|Create new file with this|name!",2," Cancel | Ok! ",button1% IF button1%=2 AND filename$<>path$ OPEN "O",#4,filename$ CLOSE #4 ELSE ALERT 2,"Error Invalid Filename!|Please type in a filename.",1," Ok! ",void% ENDIF ELSE ALERT 1,"File does not exist!|The file you selected does|not exist!",2," Retry! | Cancel! ",button2% ENDIF ENDIF UNTIL EXIST(filename$) OR filename$<>path$ RETURN ' > PROCEDURE quit_program ' PURPOSE : Asks the user whether he really wants to quit or not. ' LOCAL button% ALERT 3,"Exit Program!|Are you sure you|want to quit! ",2,"Exit|Cancel",button% IF button%=1 ! YES really exit program ' ' Check for alterations to database and if ' not saved prompt user to save database. ' ---------------------------------------- FOR size%=255 DOWNTO 1 EXIT IF type$(size%)<>"" NEXT size% IF size%<>old_size% ALERT 1,"HyperSystem has been modified|but not saved!",2," Ignore! | Save! ",button% IF button%=2 GOSUB save_hypertext ENDIF ENDIF GOSUB close_down ENDIF RETURN ' ' ' SECTION : HyperGEM Information Dialog Box ' ------------------------------------------- ' > PROCEDURE hypergem_info ' PURPOSE : Loads graphic image. (with version and logo information) ' LET info$=raster$ ! Store contents of graphic window. OPEN "I",#1,path$+"HYPERGEM.IMG" ! Open file. GOSUB load_image ! Load and uncompress graphic CLOSE #1 ! Close file. SWAP info$,raster$ ! Restore contents of graphic window. RETURN ' > PROCEDURE display_dialog_box ' PURPOSE : Displays an empty dialog box on the screen ready for ' BitBlt graphic to be moved inside it. ' LOCAL tree%,button%,dx%,dy%,dw%,dh% ~RSRC_GADDR(0,0,tree%) ~FORM_CENTER(tree%,dx%,dy%,dw%,dh%) ~OBJC_CHANGE(tree%,1,0,dx%,dy%,dw%,dh%,0,0) ~FORM_DIAL(0,dx%,dy%,dw%,dh%,dx%,dy%,dw%,dh%) ~OBJC_DRAW(tree%,0,1,dx%,dy%,dw%,dh%) GOSUB bitblt_hypergem_info(dx%,dy%,dw%,dh%) LET button%=FORM_DO(tree%,0) ~FORM_DIAL(3,dx%,dy%,dw%,dh%,dx%,dy%,dw%,dh%) RETURN ' > PROCEDURE bitblt_hypergem_info(dx%,dy%,dw%,dh%) ' PURPOSE : BitBlt hypergem_info graphic inside empty dialog box. ' LET p%(0)=0 LET p%(1)=0 LET p%(2)=p%(0)+dw%-2 LET p%(3)=p%(1)+dh%-15 LET p%(4)=dx%+3 LET p%(5)=dy% LET p%(6)=dx%+dw%-6 LET p%(7)=dy%+dh%-12 LET p%(8)=3 LET smfdb%(0)=VARPTR(info$) BITBLT smfdb%(),dmfdb%(),p%() RETURN ' ' ' SECTION : Generate New HyperSystem ' ------------------------------------ ' > PROCEDURE generate_hypersystem ' PURPOSE : Allows the user to select which window he/she would ' like to use as a title window. ' LOCAL button% ALERT 2,"Generate HyperSystem....|Please Select a Title Window|for this new system.",3," Graphic | Text | Abort! ",button% IF button%=1 GOSUB file_select("Load Graphic File: ","*.*",FALSE) IF EXIST(filename$) GOSUB prepare_hypersystem GOSUB load_graphic(filename$) ENDIF ELSE IF button%=2 GOSUB file_select("Load Text File: ","*.*",TRUE) IF EXIST(filename$) GOSUB prepare_hypersystem GOSUB load_text(filename$) ENDIF ENDIF RETURN ' > PROCEDURE prepare_hypersystem ' PURPOSE : Prepares hypersystem before system generation. ' GOSUB reset_datastructure GOSUB find_slot GOSUB close_old(handle&) MENU 16,3 ! Activate Save MENU 21,3 ! Activate Add Button LET file$(posit%)=filename$ RETURN ' ' ' SECTION : Add Button to Window ' -------------------------------- ' > PROCEDURE add_button ' PURPOSE : Identifies the current open window and determines which ' button type the user is allowed to draw on the screen. ' SELECT type$(posit%) CASE "G" GOSUB add_graphic_description CASE "T" GOSUB add_text_button ENDSELECT RETURN ' > PROCEDURE add_graphic_description ' PURPOSE : allows the user to give the new button a name. ' LOCAL tree%,button%,dx%,dy%,dw%,dh%,desc$ SPRITE cursor$ ~RSRC_GADDR(0,1,tree%) ~FORM_CENTER(tree%,dx%,dy%,dw%,dh%) ~OBJC_CHANGE(tree%,5,0,dx%,dy%,dw%,dh%,0,0) ~OBJC_CHANGE(tree%,6,0,dx%,dy%,dw%,dh%,0,0) ~FORM_DIAL(0,dx%,dy%,dw%,dh%,dx%,dy%,dw%,dh%) ~OBJC_DRAW(tree%,0,3,dx%,dy%,dw%,dh%) LET button%=FORM_DO(tree%,3) ~FORM_DIAL(3,dx%,dy%,dw%,dh%,dx%,dy%,dw%,dh%) GOSUB do_redraw(0) IF button%=5 LET desc$=CHAR{{OB_SPEC(tree%,3)}} GOSUB add_graphic_button(desc$) ENDIF RETURN ' > PROCEDURE add_graphic_button(desc$) ' PURPOSE : Allows the user to move a button in the window to its ' final location. ' ALERT 2,"POSITION BUTTON!|By clicking and holding|with the left button you|may position the button.",1," Ok! ",void% LOCAL x1%,y1%,x2%,y2%,x3%,y3%,x4%,y4%,x%,y%,b%,h%,dx%,dy%,button%,loop% ~VQT_EXTENT(desc$,x1%,y1%,x2%,y2%,x3%,y3%,x4%,y4%) WHILE MOUSEK<>1 ! Wait until left button is pressed WEND DEFMOUSE 3 ! Redefine mouse as crosshair ~WIND_GET(handle&,4,x%,y%,b%,h%) ! Get current window size IF b%>scrb%-x% ! Is window half on half off the screen LET b%=PRED(scrb%-x%) ! Reduce width to visible half of window ENDIF ' Draw button on the screen ' ---------------------------------- GET x%,y%,b%+x%,h%+y%,block$ ! Store window area in block$ WHILE MOUSEK=1 ! Loop while left button is pressed LET dx%=MOUSEX ! Store top x co-ordinate of box LET dy%=MOUSEY ! Store top y co-ordinate of box PUT x%,y%,block$ ! Replace window area with block$ PBOX dx%-5,dy%-4,dx%+x3%+5,dy%+y3%-3 ! Draw box on screen TEXT dx%,dy%+10,desc$ ! Draw text inside box VSYNC WHILE dx%=MOUSEX AND dy%=MOUSEY AND MOUSEK=1 WEND ! Wait until mouse is moved WEND DEFMOUSE 0 ! Define mouse as pointer ' Validate position and box size ' -------------------------------- IF dx%-5<0 OR dx%+x3%+5>b% OR dy%-4<0 OR dy%+y3%-3>h% ALERT 1,"Button Outside Window|Please try again!",2," Abort! | Ok! ",button% GOSUB do_redraw(0) IF button%=2 ! YES, Try drawing button again GOSUB add_graphic_button(desc$) ENDIF ENDIF ' Store box position and box size ' --------------------------------- IF button%<>2 FOR loop%=1 TO 25 EXIT IF desc$(posit%,loop%)="" ! Find empty slot for window NEXT loop% IF loop%=26 ALERT 2,"NO MORE BUTTONS AVAILABLE!|There are no more buttons|available for this window.",1," Abort! ",button% ELSE LET desc$(posit%,loop%)=desc$ ! Store button description LET xbut%(posit%,loop%)=dx%+hpos%(posit%) ! Store button x position LET ybut%(posit%,loop%)=dy%+vpos%(posit%) ! Store button y position ENDIF ENDIF RETURN ' > PROCEDURE add_text_button ' PURPOSE : Allows the user to add a button to a text window by ' dragging a box around a text phrase. ' LOCAL button1%,button2%,bx%,by%,dx%,dy%,x%,y%,b%,h%,loop% ALERT 1,"Add New Button:|Drag box around text phrase.",2," Abort | Ok!",button1% IF button1%=2 WHILE MOUSEK<>1 ! Wait until left mouse button is pressed WEND LET button2%=0 ! Clear button2% LET bx%=MOUSEX ! Store top x co-ordinate of box LET by%=MOUSEY ! Store top y co-ordinate of box DEFMOUSE 3 ! Redefine mouse as cross hair ~WIND_GET(handle&,4,x%,y%,b%,h%) ! Get current window size IF b%>scrb%-x% ! Is window half on half off the screen LET b%=PRED(scrb%-x%) ! Reduce width to visible half of window ENDIF ' Draw expanding box on the screen ' ---------------------------------- GET x%,y%,b%+x%,h%+y%,block$ ! Store window area in block$ WHILE MOUSEK=1 ! Loop while left button is pressed LET dx%=MOUSEX ! Store bottom x co-ordinate of box LET dy%=MOUSEY ! Store bottom y co-ordinate of box PUT x%,y%,block$ ! Replace window area with block$ BOX bx%,by%,dx%,dy% ! Draw box on screen WHILE dx%=MOUSEX AND dy%=MOUSEY AND MOUSEK=1 WEND ! Wait until mouse is moved WEND DEFMOUSE 0 ! Define mouse as pointer ' Validate position and box size ' -------------------------------- IF bx%>=dx% OR by%>=dy% ALERT 1,"Invalid Text Button Size|Please try again!",2," Abort! | Ok! ",button2% ELSE IF bx%<0 OR by%<0 OR dx%>b% OR dy%>h% ALERT 1,"Text Button Outside Window|Please try again!",2," Abort! | Ok! ",button2% ENDIF PUT x%,y%,block$ ! Replace window area with block$ IF button2%=2 ! YES, Try drawing button again GOSUB add_text_button ENDIF ' Store box position and box size ' --------------------------------- IF button2%<>2 FOR loop%=1 TO 25 EXIT IF desc$(posit%,loop%)="" ! Find empty slot for data NEXT loop% IF loop%=26 ALERT 2,"NO MORE BUTTONS AVAILABLE!|There are no more buttons|available for this window.",1," Abort! ",button% ELSE ' store box size as string spaces LET desc$(posit%,loop%)=SPACE$(((dx%+4)-bx%) DIV chrbb%) IF bx%>4 ! In the middle of the window LET bx%=((bx%-4) DIV chrbb%)+1 ! Resize box x position ELSE ! At the left most pos of the window LET bx%=((bx%-4) DIV chrbb%) ! Resize box x position ENDIF LET by%=((by%+4) DIV chrbh%)+1 ! Resize box y position LET xbut%(posit%,loop%)=bx%+hpos%(posit%) ! Store button x position LET ybut%(posit%,loop%)=by%+vpos%(posit%) ! Store button y position GOSUB do_redraw(0) ENDIF ENDIF ENDIF RETURN ' ' ' SECTION : Find & Evaluate Button ' ---------------------------------- ' > PROCEDURE find_button ' PURPOSE : Locate button which was clicked. ' LOCAL loop%,x1%,y1%,x2%,y2%,x3%,y3%,x4%,y4%,dx%,dy% IF MOUSEK=1 WHILE MOUSEK=1 WEND FOR loop%=1 TO 25 IF desc$(posit%,loop%)<>"" ' Get button x,y position and button size. ' ---------------------------------------- ~VQT_EXTENT(desc$(posit%,loop%),x1%,y1%,x2%,y2%,x3%,y3%,x4%,y4%) LET dx%=SUB(xbut%(posit%,loop%),hpos%(posit%)) LET dy%=SUB(ybut%(posit%,loop%),vpos%(posit%)) SELECT type$(posit%) CASE "T" IF (MOUSEX>MUL(dx%,chrbb%) AND MOUSEX<ADD(MUL(dx%,chrbb%),x3%)) AND (MOUSEY>SUB(MUL(dy%,chrbh%),18) AND MOUSEY<MUL(dy%,chrbh%)) ' Invert found button ' ------------------- GET xpos%(posit%)+MUL(dx%,chrbb%),ypos%(posit%)+PRED(MUL(dy%,chrbh%))+20,xpos%(posit%)+ADD(MUL(dx%,chrbb%),x3%),ypos%(posit%)+PRED(MUL(dy%,chrbh%))+34,s$ PUT xpos%(posit%)+MUL(dx%,chrbb%),ypos%(posit%)+MUL(dy%,chrbh%)+20,s$,10 GOSUB process_button(loop%) ENDIF CASE "G" IF (MOUSEX>SUB(dx%,5) AND MOUSEX<ADD(ADD(dx%,x3%),5)) AND (MOUSEY>SUB(dy%,4) AND MOUSEY<SUB(ADD(dy%,y3%),3)) ' Invert found button ' ------------------- GET xpos%(posit%)+SUB(dx%,3),ypos%(posit%)+dy%+34,xpos%(posit%)+ADD(ADD(dx%,x3%),5),ypos%(posit%)+ADD(dy%,y3%)+33,s$ PUT xpos%(posit%)+SUB(dx%,3),ypos%(posit%)+dy%+34,s$,10 GOSUB process_button(loop%) ENDIF ENDSELECT ENDIF NEXT loop% ENDIF RETURN ' > PROCEDURE process_button(index%) ' PURPOSE : Process button for correct event. ' GOSUB modified_text IF head%(posit%,index%)=0 IF type$(posit%)="T" OR type$(posit%)="G" GOSUB add_window(index%) ENDIF ELSE GOSUB display_next(index%) ENDIF RETURN ' > PROCEDURE add_window(index%) ' PURPOSE : Draw dialog box to allow the user to select a ' Text window, Graphic window or play a Sample. ' LOCAL tree%,dx%,dy%,dw%,dh%,button% SPRITE cursor$ ~RSRC_GADDR(0,2,tree%) ~FORM_CENTER(tree%,dx%,dy%,dw%,dh%) ~OBJC_CHANGE(tree%,10,0,dx%,dy%,dw%,dh%,0,0) ~OBJC_CHANGE(tree%,11,0,dx%,dy%,dw%,dh%,0,0) ~FORM_DIAL(0,dx%,dy%,dw%,dh%,dx%,dy%,dw%,dh%) ~OBJC_DRAW(tree%,0,3,dx%,dy%,dw%,dh%) LET button%=FORM_DO(tree%,0) ~FORM_DIAL(3,dx%,dy%,dw%,dh%,dx%,dy%,dw%,dh%) IF button%=10 GOSUB add_window2(index%,tree%) ENDIF ON MENU GOSUB do_redraw(0) RETURN ' > PROCEDURE add_window2(index%,tree%) ' PURPOSE : Allows the user to load the next window event. ' LET crea_date$(posit%)=DATE$ LET crea_time$(posit%)=TIME$ GOSUB find_slot IF posit%=256 ALERT 1,"WINDOW LIMIT REACHED!|You have reached the window limit!",1," Sorry! ",button% LET posit%=255 ELSE IF OB_STATE(tree%,8) GOSUB file_select("Load Text File: ","*.*",TRUE) IF EXIST(filename$) LET head%(old_posit%,index%)=posit% LET tail%(posit%)=old_posit% LET file$(posit%)=filename$ GOSUB load_text(filename$) ELSE LET posit%=old_posit% ENDIF ELSE IF OB_STATE(tree%,4) GOSUB file_select("Load Graphic File: ","*.*",FALSE) IF EXIST(filename$) LET head%(old_posit%,index%)=posit% LET tail%(posit%)=old_posit% LET file$(posit%)=filename$ GOSUB load_graphic(filename$) ELSE LET posit%=old_posit% ENDIF ELSE IF OB_STATE(tree%,6) GOSUB file_select("Load Sample File: ","*.*",FALSE) IF EXIST(filename$) LET head%(old_posit%,index%)=posit% LET tail%(posit%)=old_posit% LET file$(posit%)=filename$ LET type$(posit%)="S" GOSUB load_sample(filename$) ENDIF LET posit%=old_posit% ENDIF ENDIF RETURN ' > PROCEDURE find_slot ' PURPOSE : Find empty slot for new window event. ' LET old_posit%=posit% FOR posit%=1 TO 255 EXIT IF type$(posit%)="" NEXT posit% RETURN ' > PROCEDURE display_next(index%) ' PURPOSE : If a button already has a link to a new event this ' procedure will activate that next event. ' LET posit%=head%(posit%,index%) SELECT type$(posit%) CASE "T" GOSUB load_text(file$(posit%)) CASE "S" GOSUB load_sample(file$(posit%)) LET posit%=tail%(posit%) CASE "G" GOSUB load_graphic(file$(posit%)) ENDSELECT RETURN ' ' ' SECTION : Modify Existing Button ' ---------------------------------- ' > PROCEDURE find_button_modify ' PURPOSE : Locate modify button which was clicked. ' LET found!=FALSE ALERT 1,"MODIFY EXISTING BUTTON!|Please Click on button|to modify.",2," Abort! | Ok! ",button% IF button%=2 WHILE MOUSEK=0 WEND IF MOUSEK=1 FOR found%=1 TO 25 IF desc$(posit%,found%)<>"" ' Get button x,y position and button size. ' ---------------------------------------- ~VQT_EXTENT(desc$(posit%,found%),x1%,y1%,x2%,y2%,x3%,y3%,x4%,y4%) LET dx%=SUB(xbut%(posit%,found%),hpos%(posit%)) LET dy%=SUB(ybut%(posit%,found%),vpos%(posit%)) SELECT type$(posit%) CASE "T","S" IF (MOUSEX>MUL(dx%,chrbb%) AND MOUSEX<ADD(MUL(dx%,chrbb%),x3%)) AND (MOUSEY>SUB(MUL(dy%,chrbh%),18) AND MOUSEY<MUL(dy%,chrbh%)) GOSUB modify_text_button ENDIF CASE "G","S" IF (MOUSEX>SUB(dx%,5) AND MOUSEX<ADD(ADD(dx%,x3%),5)) AND (MOUSEY>SUB(dy%,4) AND MOUSEY<SUB(ADD(dy%,y3%),3)) ' Invert found button ' ------------------- GET xpos%(posit%)+SUB(dx%,3),ypos%(posit%)+dy%+34,xpos%(posit%)+ADD(ADD(dx%,x3%),5),ypos%(posit%)+ADD(dy%,y3%)+33,s$ PUT xpos%(posit%)+SUB(dx%,3),ypos%(posit%)+dy%+34,s$,10 GOSUB modify_graphic_button ENDIF ENDSELECT ENDIF NEXT found% IF found!=FALSE ALERT 2,"BUTTON NOT SELECTED!|Please, click on a button.",2," Abort! | Retry! ",button1% IF button1%=2 GOSUB find_button_modify ENDIF ENDIF ENDIF ENDIF RETURN ' > PROCEDURE modify_text_button ' PURPOSE : Allows the user to drag a box around a text phrase. ' ALERT 1,"Draw New Text Button Position:|Drag box around text phrase.",2," Abort | Ok!",butt% IF butt%=2 LET found!=TRUE WHILE MOUSEK<>1 WEND LET ans%=0 LET bx%=MOUSEX LET by%=MOUSEY DEFMOUSE 3 ~WIND_GET(handle&,4,x%,y%,b%,h%) IF b%>scrb%-x% LET b%=PRED(scrb%-x%) ENDIF ' Draw expanding box on the screen ' ---------------------------------- GET x%,y%,b%+x%,h%+y%,block$ WHILE MOUSEK=1 LET dx%=MOUSEX LET dy%=MOUSEY PUT x%,y%,block$ BOX bx%,by%,dx%,dy% WHILE dx%=MOUSEX AND dy%=MOUSEY AND MOUSEK=1 WEND WEND ' Validate position and box size ' -------------------------------- DEFMOUSE 0 IF bx%>=dx% OR by%>=dy% ALERT 1,"Invalid Text Button Size|Please try again!",2," Abort! | Ok! ",ans% ENDIF IF bx%<0 OR by%<0 OR dx%>b% OR dy%>h% ALERT 1,"Text Button Outside Window|Please try again!",2," Abort! | Ok! ",ans% ENDIF PUT x%,y%,block$ IF ans%=2 GOSUB modify_text_button ENDIF ' Store box new position and box size ' ------------------------------------- IF ans%<>2 LET desc$(posit%,found%)=SPACE$(((dx%+4)-bx%) DIV chrbb%) IF bx%>4 LET bx%=((bx%-4) DIV chrbb%)+1 ELSE LET bx%=((bx%-4) DIV chrbb%) ENDIF LET by%=((by%+4) DIV chrbh%)+1 LET xbut%(posit%,found%)=bx%+hpos%(posit%) LET ybut%(posit%,found%)=by%+vpos%(posit%) GOSUB do_redraw(0) ENDIF ENDIF RETURN ' > PROCEDURE modify_graphic_button ' PURPOSE : allows the user to change the description of an ' existing graphic window button. ' ~RSRC_GADDR(0,1,tree%) CHAR{{OB_SPEC(tree%,3)}}=desc$(posit%,found%) ~FORM_CENTER(tree%,dx%,dy%,dw%,dh%) ~OBJC_CHANGE(tree%,5,0,dx%,dy%,dw%,dh%,0,0) ~OBJC_CHANGE(tree%,6,0,dx%,dy%,dw%,dh%,0,0) ~FORM_DIAL(0,dx%,dy%,dw%,dh%,dx%,dy%,dw%,dh%) ~OBJC_DRAW(tree%,0,6,dx%,dy%,dw%,dh%) LET but%=FORM_DO(tree%,3) ~FORM_DIAL(3,dx%,dy%,dw%,dh%,dx%,dy%,dw%,dh%) GOSUB do_redraw(0) IF but%=5 LET desc$=CHAR{{OB_SPEC(tree%,3)}} GOSUB modify_button(desc$) ENDIF RETURN ' > PROCEDURE modify_button(desc$) ' PURPOSE : Allows the user to change the position of an ' existing button. ' ALERT 2,"RE-POSITION BUTTON!|By clicking and holding|with the left button you|may re-position the button.",1," Ok! ",void% LET found!=TRUE ~VQT_EXTENT(desc$,x1%,y1%,x2%,y2%,x3%,y3%,x4%,y4%) WHILE MOUSEK<>1 WEND DEFMOUSE 3 ~WIND_GET(handle&,4,x%,y%,b%,h%) IF b%>scrb%-x% LET b%=PRED(scrb%-x%) ENDIF LET desc$(posit%,found%)="" GOSUB do_redraw(0) ' Draw button on the screen ' ---------------------------------- GET x%,y%,b%+x%,h%+y%,block$ WHILE MOUSEK=1 LET dx%=MOUSEX LET dy%=MOUSEY VSYNC PUT x%,y%,block$ PBOX dx%-5,dy%-4,dx%+x3%+5,dy%+y3%-3 TEXT dx%,dy%+10,desc$ WHILE dx%=MOUSEX AND dy%=MOUSEY AND MOUSEK=1 WEND WEND DEFMOUSE 0 ' Validate position and box size ' -------------------------------- IF dx%-5<0 OR dx%+x3%+5>b% OR dy%-4<0 OR dy%+y3%-3>h% ALERT 1,"Button Outside Window|Please try again!",2," Abort! | Ok! ",ans% GOSUB do_redraw(0) ' Store box position and box size ' --------------------------------- IF ans%=2 GOSUB modify_button(desc$) ENDIF ELSE LET desc$(posit%,found%)=desc$ LET xbut%(posit%,found%)=dx%+hpos%(posit%) LET ybut%(posit%,found%)=dy%+vpos%(posit%) ENDIF RETURN ' ' ' SECTION : Erase Existing Button ' --------------------------------- ' > PROCEDURE erase_button ' PURPOSE : Locate and erase button which was clicked. ' LET found!=FALSE ALERT 1,"REMOVE EXISTING BUTTON!|Please Click on button to|remove. It will also remove|any connecting windows|to this button.",2," Abort! | Ok! ",button% IF button%=2 ALERT 2,"WARNING - This operation will|remove all windows linked|to this button.",2," Abort! | Do it! ",button% IF button%=2 WHILE MOUSEK=0 WEND IF MOUSEK=1 FOR found%=1 TO 25 IF desc$(posit%,found%)<>"" ' Get button x,y position and button size. ' ---------------------------------------- ~VQT_EXTENT(desc$(posit%,found%),x1%,y1%,x2%,y2%,x3%,y3%,x4%,y4%) LET dx%=SUB(xbut%(posit%,found%),hpos%(posit%)) LET dy%=SUB(ybut%(posit%,found%),vpos%(posit%)) SELECT type$(posit%) CASE "T","S" IF (MOUSEX>MUL(dx%,chrbb%) AND MOUSEX<ADD(MUL(dx%,chrbb%),x3%)) AND (MOUSEY>SUB(MUL(dy%,chrbh%),18) AND MOUSEY<MUL(dy%,chrbh%)) GOSUB remove_links ENDIF CASE "G","S" IF (MOUSEX>SUB(dx%,5) AND MOUSEX<ADD(ADD(dx%,x3%),5)) AND (MOUSEY>SUB(dy%,4) AND MOUSEY<SUB(ADD(dy%,y3%),3)) GOSUB remove_links ENDIF ENDSELECT ENDIF NEXT found% ENDIF IF found!=FALSE ALERT 2,"BUTTON NOT SELECTED!|Please, click on a button.",2," Abort! | Retry! ",button1% IF button1%=2 GOSUB erase_button ENDIF ENDIF ENDIF ENDIF RETURN ' > PROCEDURE remove_links ' PURPOSE : Removes any links related to this button. ' LET found!=TRUE LET mark1%=posit% LET old_posit%=posit% LET posit%=head%(posit%,found%) FOR loop%=found% TO 24 LET xbut%(old_posit%,loop%)=xbut%(old_posit%,SUCC(loop%)) LET ybut%(old_posit%,loop%)=ybut%(old_posit%,SUCC(loop%)) LET desc$(old_posit%,loop%)=desc$(old_posit%,SUCC(loop%)) LET head%(old_posit%,loop%)=head%(old_posit%,SUCC(loop%)) NEXT loop% LET xbut%(old_posit%,25)=0 LET ybut%(old_posit%,25)=0 LET desc$(old_posit%,25)="" LET head%(old_posit%,25)=0 IF posit%>0 DO FOR loop%=1 TO 25 EXIT IF head%(posit%,loop%)<>0 NEXT loop% IF loop%<26 IF head%(posit%,loop%)<>0 LET old_posit%=posit% LET posit%=head%(posit%,loop%) LET xbut%(old_posit%,loop%)=0 LET ybut%(old_posit%,loop%)=0 LET desc$(old_posit%,loop%)="" LET head%(old_posit%,loop%)=0 ENDIF ELSE GOSUB clear_record ENDIF LOOP UNTIL posit%=mark1% ENDIF LET posit%=mark1% GOSUB do_redraw(0) RETURN ' > PROCEDURE clear_record ' PURPOSE : clears an existing record. ' LET tail_posit%=tail%(posit%) LET xpos%(posit%)=50 LET ypos%(posit%)=50 LET wsiz%(posit%)=150 LET hsiz%(posit%)=150 LET hpos%(posit%)=0 LET vpos%(posit%)=0 LET crea_date$(posit%)="" LET crea_time$(posit%)="" LET type$(posit%)="" LET file$(posit%)="" LET tail%(posit%)=0 FOR i%=1 TO 25 LET xbut%(posit%,i%)=0 LET ybut%(posit%,i%)=0 LET desc$(posit%,i%)="" LET head%(posit%,i%)=0 NEXT i% LET posit%=tail_posit% RETURN ' ' ' SECTION : Draw buttons ' ------------------------ ' > PROCEDURE draw_button MENU 22,2 ! Modify Button MENU 23,2 ! Erase Button LET loop%=0 REPEAT INC loop% IF desc$(posit%,loop%)<>"" MENU 22,3 ! Modify Button MENU 23,3 ! Erase Button ~VQT_EXTENT(desc$(posit%,loop%),x1%,y1%,x2%,y2%,x3%,y3%,x4%,y4%) LET dx%=SUB(xbut%(posit%,loop%),hpos%(posit%)) LET dy%=SUB(ybut%(posit%,loop%),vpos%(posit%)) SELECT type$(posit%) CASE "G" PBOX SUB(dx%,5),SUB(dy%,4),ADD(ADD(dx%,x3%),5),SUB(ADD(dy%,y3%),3) TEXT dx%,ADD(dy%,10),desc$(posit%,loop%) CASE "T" LINE MUL(dx%,chrbb%),PRED(MUL(dy%,chrbh%)),ADD(MUL(dx%,chrbb%),x3%),PRED(MUL(dy%,chrbh%)) LINE MUL(dx%,chrbb%),MUL(dy%,chrbh%),ADD(MUL(dx%,chrbb%),x3%),MUL(dy%,chrbh%) ENDSELECT ENDIF UNTIL desc$(posit%,loop%)="" RETURN ' ' ' HyperText Load & Save Procedures ' ---------------------------------- ' > PROCEDURE load_hypertext ' PURPOSE : Load HyperText Database file. ' LOCAL button%,loop%,i%,size%,buts% GOSUB file_select("Load HyperSystem: ","*.HYP",FALSE) IF EXIST(filename$) GOSUB close_old(handle&) DEFMOUSE iomouse$ GOSUB prepare_hypersystem OPEN "I",#1,filename$ INPUT #1;ver$ IF ver$<>"HyperGEM 1.0" CLOSE #1 DEFMOUSE 0 ALERT 1,"HyperGEM File Error!|This is not a valid|HyperGEM data file.",1," Error! ",void% ELSE INPUT #1;size% LET old_size%=size% FOR loop%=1 TO size% INPUT #1;xpos%(loop%),ypos%(loop%),wsiz%(loop%),hsiz%(loop%),hpos%(loop%),vpos%(loop%) INPUT #1;crea_date$(loop%),crea_time$(loop%),type$(loop%),file$(loop%),tail%(loop%) INPUT #1;buts% FOR i%=1 TO buts% INPUT #1;xbut%(loop%,i%),ybut%(loop%,i%),desc$(loop%,i%),head%(loop%,i%) NEXT i% NEXT loop% CLOSE #1 DEFMOUSE 0 MENU 13,3 ! Run HyperSystem MENU 16,3 ! Activate Save ALERT 1,"HyperSystem Loaded!",2," Run! | Ready! ",button% IF button%=1 GOSUB run_hypertext ENDIF ENDIF ENDIF RETURN ' > PROCEDURE save_hypertext ' PURPOSE : Save HyperText Database file. ' GOSUB file_select("Save HyperSystem: ","*.HYP",TRUE) IF EXIST(filename$) IF EXIST(LEFT$(filename$,LEN(filename$)-3)+"BAK") KILL LEFT$(filename$,LEN(filename$)-3)+"BAK" ENDIF IF EXIST(filename$) NAME filename$ AS LEFT$(filename$,LEN(filename$)-3)+"BAK" ENDIF DEFMOUSE iomouse$ FOR size%=255 DOWNTO 1 EXIT IF type$(size%)<>"" NEXT size% LET old_size%=size% OPEN "O",#1,filename$ WRITE #1;"HyperGEM 1.0",size% FOR loop%=1 TO size% WRITE #1;xpos%(loop%),ypos%(loop%),wsiz%(loop%),hsiz%(loop%),hpos%(loop%),vpos%(loop%) WRITE #1;crea_date$(loop%),crea_time$(loop%),type$(loop%),file$(loop%),tail%(loop%) FOR buts%=25 DOWNTO 1 EXIT IF desc$(loop%,buts%)<>"" NEXT buts% WRITE #1;buts% FOR i%=1 TO buts% WRITE #1;xbut%(loop%,i%),ybut%(loop%,i%),desc$(loop%,i%),head%(loop%,i%) NEXT i% NEXT loop% CLOSE #1 DEFMOUSE 0 ALERT 1,"HyperSystem Saved!",1," Ready! ",button% ON MENU ENDIF RETURN ' > PROCEDURE run_hypertext ' PURPOSE : Run HyperText Database file. ' MENU 21,3 ! Activate Add Button LET posit%=1 SELECT type$(posit%) CASE "G" GOSUB load_graphic(file$(posit%)) CASE "T" GOSUB load_text(file$(posit%)) ENDSELECT RETURN ' ' ' Text Editor Management Procedures ' ----------------------------------- ' PROCEDURE load_text(filename$) ' PURPOSE : Load Text File. ' VOID (0)=FRE(0) LET ygrap%=9 ! set minimum text lines to nine FOR loop%=0 TO 4000 LET txt$(loop%)="" ! clear text array NEXT loop% IF EXIST(filename$) LET extender$=RIGHT$(filename$,3) ! NOTE: file extension DEFMOUSE iomouse$ OPEN "I",#1,filename$ ! open file RECALL #1,txt$(),-1,ygrap% ! load text file CLOSE #1 ! close file ENDIF IF ygrap%<9 LET ygrap%=9 ! set minimum text lines to nine ENDIF LET xgrap%=80 ! set line length to 80 characters DEFMOUSE 0 GOSUB open_window("T") ! open text window GOSUB modwind(handle&,xpos%(posit%),ypos%(posit%),wsiz%(posit%),hsiz%(posit%)) LET tpox%=hpos%(posit%) ! set text home x position LET tpoy%=vpos%(posit%) ! set text home y position GOSUB cursor_resize GOSUB insert_key RETURN ' > PROCEDURE modified_text ' PURPOSE : Give the user the option to save modified text or to lose it! ' LOCAL button% IF edited!=TRUE ALERT 1,"TEXT FILE MODIFIED!|Text File has been modified|but not saved!",2," Lose! | Save! ",button% LET edited!=FALSE IF button%=2 GOSUB esc_key ENDIF ENDIF RETURN ' > PROCEDURE keyboard GOSUB menu_key IF type$(posit%)="T" ~WIND_GET(handle&,4,x%,y%,b%,h%) GOSUB draw_cursor(tpox%,tpoy%,FALSE) GOSUB enter_text ENDIF RETURN ' > PROCEDURE menu_key ' PURPOSE : Gets a keypress and checks to see if it is ' a menu event keypress and if it is activates ' the appropriate menu option. ' LET menu_key%=MENU(14) IF menu_key%>4607 AND menu_key%<12801 MENU OFF IF menu_key%=5888 ! Alt I GOSUB hypergem_info ELSE IF menu_key%=8704 ! Alt G GOSUB generate_hypersystem ELSE IF menu_key%=4864 ! Alt R GOSUB run_hypertext ELSE IF menu_key%=9728 ! Alt L GOSUB load_hypertext ELSE IF menu_key%=7936 ! Alt S GOSUB save_hypertext ELSE IF menu_key%=4096 ! Alt Q GOSUB quit_program ELSE IF menu_key%=7680 ! Alt A GOSUB add_button ELSE IF menu_key%=4608 ! Alt E GOSUB erase_button ELSE IF menu_key%=12800 ! Alt M GOSUB find_button_modify ENDIF ENDIF RETURN ' > PROCEDURE enter_text ' PURPOSE : Lets the user add text to a text window. ' LET key%=BYTE(MENU(14)) ! get ASCII key code IF key%>31 AND key%<127 ! restrict keyboard input range LET edited!=TRUE ! text is being edited flag! IF tpox%>LEN(txt$(PRED(tpoy%))) ! is cursor at end of string LET txt$(PRED(tpoy%))=txt$(PRED(tpoy%))+SPACE$(tpox%-LEN(txt$(PRED(tpoy%)))) IF tpox%=xgrap% ! wrap around cursor to next line GOSUB return_key ENDIF ENDIF IF insert!=TRUE ! if insert mode LET txt$(PRED(tpoy%))=LEFT$(txt$(PRED(tpoy%)),PRED(tpox%))+CHR$(key%)+RIGHT$(txt$(PRED(tpoy%)),LEN(txt$(PRED(tpoy%)))-PRED(tpox%)) GOSUB right_key ELSE ! else overwrite mode MID$(txt$(PRED(tpoy%)),tpox%)=CHR$(key%) GOSUB right_key ENDIF ELSE GOSUB text_functions GOSUB draw_cursor(tpox%,tpoy%,TRUE) ENDIF RETURN ' > PROCEDURE text_functions ' PURPOSE : Interprets keypresses for 'Return', 'BackSpace', 'Delete' ' 'ESc Key', 'Insert', 'Down', 'Up', 'Left' & 'Right Key' ' IF key%=13 GOSUB return_key ELSE IF key%=8 GOSUB backspace_key ELSE IF key%=127 GOSUB delete_key ELSE IF key%=27 GOSUB esc_key ENDIF SELECT MENU(14) CASE 20480 GOSUB down_key CASE 18432 GOSUB up_key CASE 19200 ! left GOSUB left_key CASE 19712 ! right GOSUB right_key CASE 20992 ! insert GOSUB insert_key ENDSELECT RETURN ' > PROCEDURE draw_cursor(tpox%,tpoy%,state!) ' PURPOSE : Calculates the cursor position from the text position. ' It works by converting text co-ordinates into graphic ' co-ordinates. ie. 25 X 80 = 400 X 640 ' LET curx%=ADD(x%,SUB(SUB(MUL(tpox%,chrbb%),8),MUL(hpos%(posit%),chrbb%))) LET cury%=ADD(y%,SUB(MUL(PRED(tpoy%),chrbh%),MUL(vpos%(posit%),chrbh%))) IF state!=TRUE SPRITE cursor$,curx%,cury% ELSE SPRITE cursor$ ENDIF RETURN ' > PROCEDURE esc_key ' PURPOSE : Allows the user to save the edited text window to disk. ' ALERT 1,"SAVE TEXT FILE!|Save this edited text file|to disk.|",2," Cancel | Ok! ",button% IF button%=2 LET edited!=FALSE SPRITE cursor$ GOSUB file_select("Save Text File: ","*.ASC",TRUE) ' ' if the file already exists rename as filename.bak ' ------------------------------------------------- IF EXIST(filename$) IF EXIST(LEFT$(filename$,LEN(filename$)-3)+"BAK") KILL LEFT$(filename$,LEN(filename$)-3)+"BAK" ENDIF IF EXIST(filename$) NAME filename$ AS LEFT$(filename$,LEN(filename$)-3)+"BAK" ENDIF DEFMOUSE iomouse$ LET file$(posit%)=filename$ OPEN "O",#1,filename$ ! create text file STORE #1,txt$(),0 TO ygrap% ! save text CLOSE #1 ! close file DEFMOUSE 0 ALERT 1,"Text File Saved!",1," Ok! ",void% ENDIF ENDIF RETURN ' > PROCEDURE insert_key ' PURPOSE : Set text editor mode to insert or to overwrite mode. ' LET insert!=NOT (insert!) IF insert!=TRUE LET insert$="Insert " ELSE LET insert$="Overwrite" ENDIF GOSUB wind_title(handle&," Text Window ") GOSUB wind_info(handle&,"Col:"+STR$(tpox%)+" Row:"+STR$(tpoy%)+" "+insert$) RETURN ' > PROCEDURE up_key ' PURPOSE : Move the cursor up one character position. ' IF tpoy%>1 DEC tpoy% GOSUB draw_cursor(tpox%,tpoy%,FALSE) ' Move the window down one character position. ' -------------------------------------------- IF cury%=SUB(y%,16) LET vpos%(posit%)=MAX(PRED(vpos%(posit%)),0) IF b%>SUB(scrb%,x%) LET b%=SUB(scrb%,x%) ENDIF GET x%,y%,PRED(ADD(x%,b%)),SUB(ADD(y%,h%),17),block$ PUT x%,ADD(y%,16),block$ GOSUB draw_cursor(tpox%,tpoy%,FALSE) GOSUB do_redraw(1) GOSUB draw_button GOSUB calc_slid(handle&) ENDIF ENDIF RETURN ' > PROCEDURE left_key ' PURPOSE : Move the cursor left one character position. ' IF tpox%>1 DEC tpox% GOSUB draw_cursor(tpox%,tpoy%,FALSE) ' Move the window right one character position. ' --------------------------------------------- IF curx%=SUB(x%,8) LET hpos%(posit%)=MAX(PRED(hpos%(posit%)),0) GOSUB do_redraw(0) ENDIF GOSUB do_redraw(1) ENDIF RETURN ' > PROCEDURE down_key ' PURPOSE : Move the cursor down one character position. ' IF tpoy%<ygrap% INC tpoy% GOSUB draw_cursor(tpox%,tpoy%,FALSE) ' Move the window up one character position. ' ------------------------------------------ IF cury%=>SUB(ADD(h%,y%),2) LET vpos%(posit%)=MIN(SUCC(vpos%(posit%)),SUB(ygrap%,DIV(h%,chrbh%))) IF b%>SUB(scrb%,x%) LET b%=SUB(scrb%,x%) ENDIF GET x%,ADD(y%,16),PRED(ADD(x%,b%)),PRED(ADD(y%,h%)),block$ PUT x%,y%,block$ COLOR 0 LINE 0,SUB(h%,2),b%,SUB(h%,2) COLOR 1 GOSUB draw_cursor(tpox%,tpoy%,FALSE) GOSUB do_redraw(1) GOSUB draw_button GOSUB calc_slid(handle&) ENDIF ENDIF RETURN ' > PROCEDURE right_key ' PURPOSE : Move the cursor right one character position. ' IF tpox%<xgrap% INC tpox% GOSUB draw_cursor(tpox%,tpoy%,FALSE) ' Move the window left one character position. ' ------------------------------------------ IF curx%=>ADD(b%,x%) LET hpos%(posit%)=MIN(SUCC(hpos%(posit%)),SUB(xgrap%,DIV(b%,chrbb%))) GOSUB do_redraw(0) ENDIF GOSUB do_redraw(1) ENDIF RETURN ' > PROCEDURE return_key ' PURPOSE : code for activation of return key. ' LOCAL temp% ' handle insert mode with return. IF insert!=TRUE IF tpox%<=LEN(txt$(PRED(tpoy%))) AND tpox%>1! cursor in middle of line so split line INSERT txt$(tpoy%)=RIGHT$(txt$(PRED(tpoy%)),LEN(txt$(PRED(tpoy%)))-PRED(tpox%)) LET txt$(PRED(tpoy%))=LEFT$(txt$(PRED(tpoy%)),PRED(tpox%)) ELSE IF tpox%=1 ! insert blank line on current line INSERT txt$(PRED(tpoy%))="" ELSE IF tpox%>LEN(txt$(PRED(tpoy%))) ! insert blank line on next line INSERT txt$(tpoy%)="" ENDIF INC ygrap% ' move any buttons which are further down the document or equal to the ' current line down one character position. ' -------------------------------------------------------------------- FOR loop%=1 TO 25 IF ybut%(posit%,loop%)>=tpoy% LET ybut%(posit%,loop%)=SUCC(ybut%(posit%,loop%)) ENDIF NEXT loop% ENDIF LET tpox%=1 LET temp%=hpos%(posit%) LET hpos%(posit%)=0 ' tidy up GOSUB draw_cursor(tpox%,tpoy%,FALSE) GOSUB calc_slid(handle&) IF temp%>0 OR insert!=TRUE GOSUB do_redraw(0) ENDIF GOSUB down_key RETURN ' > PROCEDURE backspace_key ' PURPOSE : code for activation of backspace key. ' IF tpox%>1 AND tpox%<=SUCC(LEN(txt$(PRED(tpoy%)))) ! cursor in middle of line LET txt$(PRED(tpoy%))=LEFT$(txt$(PRED(tpoy%)),SUB(tpox%,2))+RIGHT$(txt$(PRED(tpoy%)),LEN(txt$(PRED(tpoy%)))-PRED(tpox%)) GOSUB left_key ELSE IF tpox%=1 AND tpoy%>1 ! cursor at beginning of line ' move remaining line to previous line and remove current line. ' ------------------------------------------------------------- LET tpox%=MAX(1,SUCC(LEN(txt$(tpoy%-2)))) LET txt$(tpoy%-2)=txt$(tpoy%-2)+txt$(PRED(tpoy%)) DELETE txt$(PRED(tpoy%)) IF ygrap%>5 ! limit text size to a minimum of 5 lines DEC ygrap% ENDIF ' move any buttons which are further down the document or equal to the ' current line down one character position. ' -------------------------------------------------------------------- FOR loop%=1 TO 25 IF ybut%(posit%,loop%)>=tpoy% LET ybut%(posit%,loop%)=PRED(ybut%(posit%,loop%)) ENDIF NEXT loop% GOSUB up_key GOSUB calc_slid(handle&) GOSUB do_redraw(0) GOSUB cursor_resize ENDIF GOSUB draw_cursor(tpox%,tpoy%,FALSE) RETURN ' > PROCEDURE delete_key ' PURPOSE : code for activation of delete key. ' IF tpox%<=LEN(txt$(PRED(tpoy%))) LET txt$(PRED(tpoy%))=LEFT$(txt$(PRED(tpoy%)),PRED(tpox%))+RIGHT$(txt$(PRED(tpoy%)),LEN(txt$(PRED(tpoy%)))-tpox%) GOSUB do_redraw(1) ENDIF ' if cursor position is greater than line length then add next line ' to current line and remove next line. ' ----------------------------------------------------------------- IF tpox%>LEN(txt$(PRED(tpoy%))) LET txt$(PRED(tpoy%))=txt$(PRED(tpoy%))+txt$(tpoy%) DELETE txt$(tpoy%) IF ygrap%>5 DEC ygrap% ENDIF ' move any buttons which are further down the document or equal to the ' current line down one character position. ' -------------------------------------------------------------------- FOR loop%=1 TO 25 IF ybut%(posit%,loop%)>=tpoy% LET ybut%(posit%,loop%)=PRED(ybut%(posit%,loop%)) ENDIF NEXT loop% GOSUB calc_slid(handle&) GOSUB do_redraw(0) GOSUB cursor_resize ENDIF RETURN ' ' ' General Load Picture Procedures ' --------------------------------- ' > PROCEDURE load_graphic(filename$) ' PURPOSE : identify graphic file and branch to appropriate routine ' DEFMOUSE iomouse$ LET extender$=RIGHT$(filename$,3) ! NOTE: file extension OPEN "I",#1,filename$ IF extender$="PI3" OR extender$="PI1" GOSUB load_degas ELSE IF extender$="PC3" OR extender$="PC1" GOSUB load_degas_elite ELSE IF extender$="TN3" OR extender$="TN1" GOSUB load_tiny ELSE IF extender$="IMG" GOSUB load_image IF EXIST(filename$) GOSUB display_graphic ENDIF ELSE DEFMOUSE 0 ALERT 1,"Picture Format NOT recognised|at this time.|"+filename$,1," Cancel! ",void% LET head%(old_posit%,index%)=0 LET tail%(posit%)=0 LET file$(posit%)="FILENAME.TXT" LET posit%=old_posit% ENDIF CLOSE #1 RETURN ' > PROCEDURE display_graphic ' PURPOSE : Prepare and open graphic window. ' GOSUB open_window("G") GOSUB modwind(handle&,xpos%(posit%),ypos%(posit%),wsiz%(posit%),hsiz%(posit%)) DEFMOUSE 0 LET wf!=FALSE RETURN ' > PROCEDURE get_palette ' PURPOSE : Load palette data and convert from RGB to single value. ' LET pal$=INPUT$(32,#1) ! get palette data LET count%=1 FOR loop%=0 TO 31 STEP 2 LET r=(PEEK(VARPTR(pal$)+loop%)/7)*0.3 ! calculate red component LET g=(FN col(4,loop%)/7)*0.11 ! calculate green component LET b=(SHR(FN col(0,loop%),4)/7)*0.59 ! calculate blue component LET col|(count%)=(r+g+b)*18 ! create single intensity value INC count% NEXT loop% RETURN ' > FUNCTION col(cbit%,cpro%) ' PURPOSE : get colour palette lookup entry. ' LET cbuf%=PEEK(VARPTR(pal$)+SUCC(cpro%)) FOR cloop%=cbit% TO ADD(cbit%,4) LET cbuf%=BCLR(cbuf%,cloop%) NEXT cloop% RETURN cbuf% ENDFUNC ' ' ' Load Degas Uncompressed Picture ' --------------------------------- ' > PROCEDURE load_degas ' PURPOSE : This procedure will load a uncompressed degas elite ' format picture into memory. ' LET res$=INPUT$(2,#1) GOSUB get_palette LET raster$=INPUT$(32000,#1) LET xgrap%=640 LET ygrap%=400 IF extender$="PI1" GOSUB reorder_planes GOSUB prepare_dither GOSUB ordered_dither LET xgrap%=320 LET ygrap%=200 ENDIF GOSUB display_graphic RETURN ' > PROCEDURE reorder_planes ' PURPOSE : Reorder bit planes for colour to mono conversion. ' LET temp$=raster$ LET st%=VARPTR(temp$) LET scr%=VARPTR(raster$) LET line%=scr% FOR loop%=st% TO ADD(st%,31999) STEP 8 DPOKE line%,DPEEK(loop%) DPOKE ADD(line%,8000),DPEEK(ADD(loop%,2)) DPOKE ADD(line%,16000),DPEEK(ADD(loop%,4)) DPOKE ADD(line%,24000),DPEEK(ADD(loop%,6)) ADD line%,2 NEXT loop% RETURN ' ' ' Load Degas Compressed Picture ' ------------------------------- ' > PROCEDURE load_degas_elite ' PURPOSE : This procedure will load a compressed degas elite format ' picture into memory and uncompress it. ' LET res$=INPUT$(2,#1) GOSUB get_palette LET st%=VARPTR(raster$) LET size%=ADD(st%,32000) WHILE (st%<size%) LET store%=INP(#1) IF (store%<128) GOSUB not_comp ELSE GOSUB compressed ENDIF WEND LET xgrap%=640 LET ygrap%=400 IF extender$="PC1" GOSUB reorder_planes_compressed GOSUB prepare_dither GOSUB ordered_dither LET xgrap%=320 LET ygrap%=200 ENDIF GOSUB display_graphic RETURN ' > PROCEDURE reorder_planes_compressed ' PURPOSE : Reorder bit planes for colour to mono conversion. ' LET temp$=raster$ LET st%=VARPTR(temp$) LET scr%=VARPTR(raster$) LET line%=st% LET scan%=ADD(st%,40) FOR loop%=scr% TO ADD(scr%,7999) STEP 2 DPOKE loop%,DPEEK(line%) DPOKE ADD(loop%,8000),DPEEK(ADD(line%,40)) DPOKE ADD(loop%,16000),DPEEK(ADD(line%,80)) DPOKE ADD(loop%,24000),DPEEK(ADD(line%,120)) ADD line%,2 IF scan%=line% ADD line%,120 scan%=ADD(line%,40) ENDIF NEXT loop% RETURN ' > PROCEDURE compressed ' PURPOSE : use the next byte -store% + 1 times. ' LET store%=SUCC((NOT store%) AND &HFF) LET buf%=INP(#1) WHILE NOT store% POKE st%,buf% INC st% DEC store% WEND RETURN ' > PROCEDURE not_comp ' PURPOSE : use the next store% + 1 bytes literally. ' WHILE NOT store% POKE st%,INP(#1) INC st% DEC store% WEND RETURN ' ' ' Load Tiny Compressed Picture ' ------------------------------ ' > PROCEDURE load_tiny ' PURPOSE : This procedure will load a compressed tiny format picture ' into memory and uncompress it. ' LET res%=INP(#1) GOSUB get_palette LET temp$=INPUT$(4,#1) ! Get # of control bytes and data words LET lcode%=DPEEK(VARPTR(temp$)) ! Length of code table LET lcode$=INPUT$(lcode%,#1) ! read in code table data LET ldata$=INPUT$(DPEEK(VARPTR(temp$)+2)*2,#1) ! read in data words data LET ptrco%=VARPTR(lcode$) ! remove pointer evaluation from loops LET ptrda%=VARPTR(ldata$) LET raster$=STRING$(32000,0) LET st%=VARPTR(raster$) LET ixpic%=0 LET ixcode%=0 LET ixdata%=0 ' WHILE ixcode%<lcode% LET coval%=PEEK(ptrco%+ixcode%) IF coval%=0 ! 0= 16 bit repeat count GOSUB repeat_count16 ELSE IF coval%=1 ! 1= 16 bit string length GOSUB string_length16 ELSE IF coval%<128 ! 2..127 = repeat count GOSUB repeat_count ELSE ! 128..255 = two's complement string length GOSUB twos_complement ENDIF WEND ' IF res%=0 ! is it a low resolution graphic LET temp$=raster$ GOSUB reorder_planes GOSUB prepare_dither GOSUB ordered_dither LET xgrap%=320 ! picture width LET ygrap%=200 ! picture height ELSE ! is it a high resolution graphic LET xgrap%=640 ! picture width LET ygrap%=400 ! picture height ENDIF LET lcode$="" LET ldata$="" GOSUB display_graphic RETURN ' > PROCEDURE repeat_count16 ' PURPOSE : 1 word is taken from the control section which specifies the ' number of times to repeat the next data word from (128 to 32767) ' LET coval%=ADD(MUL(PEEK(SUCC(ADD(ptrco%,ixcode%))),256),PEEK(ADD(ADD(ptrco%,ixcode%),2))) ADD ixcode%,3 GOSUB getdata FOR loop%=1 TO coval% GOSUB putdata NEXT loop% RETURN ' > PROCEDURE string_length16 ' PURPOSE : 1 word is taken from the control section which specifies the ' number of unique words to be taken from the data section. ' (from 128 - 32767) ' LET coval%=ADD(MUL(PEEK(SUCC(ADD(ptrco%,ixcode%))),256),PEEK(ADD(ADD(ptrco%,ixcode%),2))) ADD ixcode%,3 FOR loop%=1 TO coval% GOSUB getdata GOSUB putdata NEXT loop% RETURN ' > PROCEDURE repeat_count ' PURPOSE : specifies the number of times to repeat the next word ' taken from the data section. (from 2 to 127) ' INC ixcode% GOSUB getdata FOR loop%=1 TO coval% GOSUB putdata NEXT loop% RETURN ' > PROCEDURE twos_complement ' PURPOSE : absolute value specifies the number of unique words to ' take from the data section. (from 1 to 127) ' INC ixcode% LET coval%=SUB(256,coval%) FOR loop%=1 TO coval% GOSUB getdata GOSUB putdata NEXT loop% RETURN ' > PROCEDURE getdata ' PURPOSE : gets a word from the data string. ' pword%=DPEEK(ADD(ptrda%,ixdata%)) ADD ixdata%,2 RETURN ' > PROCEDURE putdata ' PURPOSE : puts a word into the output string. ' DPOKE ADD(st%,ixpic%),pword% ADD ixpic%,160 IF ixpic%>=32000 ADD ixpic%,8 SUB ixpic%,32000 IF ixpic%>=160 ADD ixpic%,2 SUB ixpic%,160 ENDIF ENDIF RETURN ' ' ' Load Compressed Image Picture ' ------------------------------- ' > PROCEDURE load_image ' PURPOSE : This procedure will load a compressed image format picture ' into memory and uncompress it. ' LET temp$=INPUT$(4,#1) LET temp$=INPUT$((DPEEK(VARPTR(temp$)+2)*2)-4,#1) ! read in rest of header LET pattern%=DPEEK(VARPTR(temp$)+2) ! pattern length LET width%=((DPEEK(VARPTR(temp$)+8)-1)/8) ! line width in pixels LET lines%=DPEEK(VARPTR(temp$)+10) ! number of lines IF lines%<=400 AND DPEEK(VARPTR(temp$)+8)<=640 ! is it suitable size LET xgrap%=DPEEK(VARPTR(temp$)+8) ! width of graphic LET ygrap%=lines% ! height of graphic LET raster$=STRING$(32000,0) LET st%=VARPTR(raster$) LET start%=st% WHILE NOT EOF(#1) LET x%=INP(#1) IF x%=0 ! Pattern or Scanline Run LET n%=INP(#1) IF n%>0 GOSUB pattern ELSE IF n%=0 ! Scanline Run LET n%=INP(#1) LET scan%=INP(#1) LET scanrun!=TRUE ENDIF ELSE IF x%=&H80 ! Uncompressed bit string GOSUB uncompressed ELSE ! Solid run GOSUB solid_run ENDIF WEND ELSE LET extender$="" ALERT 1,"The Image File is to large for|this application.",1," Cancel! ",void% ENDIF RETURN ' > PROCEDURE pattern ' PURPOSE : read a number of bytes equal to the "pattern length" word ' in the header. Repeat this pattern n% times. ' LET temp$=INPUT$(pattern%,#1) FOR loop%=1 TO n% FOR nloop%=1 TO pattern% POKE st%,PRED(ADD(PEEK(VARPTR(temp$)),nloop%)) GOSUB counter NEXT nloop% NEXT loop% RETURN ' > PROCEDURE counter ' PURPOSE : scanline run. Data for the next scanline is be used ' multiple times and also handle output byte position. ' INC st% IF SUB(st%,start%)>width% LET start%=ADD(start%,80) LET st%=start% IF scanrun!=TRUE WHILE scan%>0 POKE st%,PEEK(SUB(st%,80)) INC st% IF SUB(st%,start%)>width% LET start%=ADD(start%,80) LET st%=start% DEC scan% ENDIF WEND LET scanrun!=FALSE ENDIF ENDIF RETURN ' > PROCEDURE uncompressed ' PURPOSE : uncompressed bit string. The next byte determines the ' number of bytes to use literally. The literal data ' bytes follow. ' LET n%=INP(#1) FOR loop%=1 TO n% POKE st%,INP(#1) GOSUB counter NEXT loop% RETURN ' > PROCEDURE solid_run ' PURPOSE : solid run. The value of x% determines what to draw. ' The high bit specifies whether the pixels are set or ' cleared. A 1 specifies a byte run using $FF, a 0 ' indicates a byte run using $00. The low 7 bits, taken ' as an unsigned quantity, specify the length of the ' run in bytes. ' IF BTST(x%,7) LET x%=BCLR(x%,7) FOR loop%=1 TO x% POKE st%,&HFF GOSUB counter NEXT loop% ELSE FOR loop%=1 TO x% GOSUB counter NEXT loop% ENDIF RETURN ' ' ' Ordered Dither Procedures ' --------------------------- ' > PROCEDURE prepare_dither ' PURPOSE : This procedure checks for the setting of each bit on each bit ' plane and uses the combined value of these bit planes as a ' index to the lookup palette table. It then moves this ' intensity into a sequential array for every pixel. ' LET st%=VARPTR(raster$) DEFMOUSE paintcan$ LET x%=0 FOR y%=0 TO 7999 STEP 2 LET p0%=ADD(y%,st%) LET p1%=DPEEK(p0%) LET p2%=DPEEK(ADD(p0%,8000)) LET p3%=DPEEK(ADD(p0%,16000)) LET p4%=DPEEK(ADD(p0%,24000)) ' work on a complete word in one go. ' ---------------------------------- LET pic|(x%)=col|(ADD(ADD(ADD(ADD(ABS(BTST(p1%,0)),MUL(ABS(BTST(p2%,0)),2)),MUL(ABS(BTST(p3%,0)),4)),MUL(ABS(BTST(p4%,0)),8)),1)) LET pic|(SUCC(x%))=col|(ADD(ADD(ADD(ADD(ABS(BTST(p1%,1)),MUL(ABS(BTST(p2%,1)),2)),MUL(ABS(BTST(p3%,1)),4)),MUL(ABS(BTST(p4%,1)),8)),1)) LET pic|(ADD(x%,2))=col|(ADD(ADD(ADD(ADD(ABS(BTST(p1%,2)),MUL(ABS(BTST(p2%,2)),2)),MUL(ABS(BTST(p3%,2)),4)),MUL(ABS(BTST(p4%,2)),8)),1)) LET pic|(ADD(x%,3))=col|(ADD(ADD(ADD(ADD(ABS(BTST(p1%,3)),MUL(ABS(BTST(p2%,3)),2)),MUL(ABS(BTST(p3%,3)),4)),MUL(ABS(BTST(p4%,3)),8)),1)) LET pic|(ADD(x%,4))=col|(ADD(ADD(ADD(ADD(ABS(BTST(p1%,4)),MUL(ABS(BTST(p2%,4)),2)),MUL(ABS(BTST(p3%,4)),4)),MUL(ABS(BTST(p4%,4)),8)),1)) LET pic|(ADD(x%,5))=col|(ADD(ADD(ADD(ADD(ABS(BTST(p1%,5)),MUL(ABS(BTST(p2%,5)),2)),MUL(ABS(BTST(p3%,5)),4)),MUL(ABS(BTST(p4%,5)),8)),1)) LET pic|(ADD(x%,6))=col|(ADD(ADD(ADD(ADD(ABS(BTST(p1%,6)),MUL(ABS(BTST(p2%,6)),2)),MUL(ABS(BTST(p3%,6)),4)),MUL(ABS(BTST(p4%,6)),8)),1)) LET pic|(ADD(x%,7))=col|(ADD(ADD(ADD(ADD(ABS(BTST(p1%,7)),MUL(ABS(BTST(p2%,7)),2)),MUL(ABS(BTST(p3%,7)),4)),MUL(ABS(BTST(p4%,7)),8)),1)) LET pic|(ADD(x%,8))=col|(ADD(ADD(ADD(ADD(ABS(BTST(p1%,8)),MUL(ABS(BTST(p2%,8)),2)),MUL(ABS(BTST(p3%,8)),4)),MUL(ABS(BTST(p4%,8)),8)),1)) LET pic|(ADD(x%,9))=col|(ADD(ADD(ADD(ADD(ABS(BTST(p1%,9)),MUL(ABS(BTST(p2%,9)),2)),MUL(ABS(BTST(p3%,9)),4)),MUL(ABS(BTST(p4%,9)),8)),1)) LET pic|(ADD(x%,10))=col|(ADD(ADD(ADD(ADD(ABS(BTST(p1%,10)),MUL(ABS(BTST(p2%,10)),2)),MUL(ABS(BTST(p3%,10)),4)),MUL(ABS(BTST(p4%,10)),8)),1)) LET pic|(ADD(x%,11))=col|(ADD(ADD(ADD(ADD(ABS(BTST(p1%,11)),MUL(ABS(BTST(p2%,11)),2)),MUL(ABS(BTST(p3%,11)),4)),MUL(ABS(BTST(p4%,11)),8)),1)) LET pic|(ADD(x%,12))=col|(ADD(ADD(ADD(ADD(ABS(BTST(p1%,12)),MUL(ABS(BTST(p2%,12)),2)),MUL(ABS(BTST(p3%,12)),4)),MUL(ABS(BTST(p4%,12)),8)),1)) LET pic|(ADD(x%,13))=col|(ADD(ADD(ADD(ADD(ABS(BTST(p1%,13)),MUL(ABS(BTST(p2%,13)),2)),MUL(ABS(BTST(p3%,13)),4)),MUL(ABS(BTST(p4%,13)),8)),1)) LET pic|(ADD(x%,14))=col|(ADD(ADD(ADD(ADD(ABS(BTST(p1%,14)),MUL(ABS(BTST(p2%,14)),2)),MUL(ABS(BTST(p3%,14)),4)),MUL(ABS(BTST(p4%,14)),8)),1)) LET pic|(ADD(x%,15))=col|(ADD(ADD(ADD(ADD(ABS(BTST(p1%,15)),MUL(ABS(BTST(p2%,15)),2)),MUL(ABS(BTST(p3%,15)),4)),MUL(ABS(BTST(p4%,15)),8)),1)) ADD x%,16 NEXT y% RETURN ' > PROCEDURE ordered_dither ' PURPOSE : this procedure extracts the intensity of a pixel ' and compares with the value in the dither matrix. ' From this result the corresponding output bit is ' set on or off. ' DEFMOUSE pencil$ LET raster$=STRING$(32000,0) LET scr%=VARPTR(raster$) LET word%=scr% LET scan%=ADD(word%,40) FOR z%=0 TO 63999 STEP 16 ' work on a complete word in one go. ' ---------------------------------- LET p0%=ABS(pic|(z%)<dither2|(z%)) LET p1%=MUL(ABS(pic|(SUCC(z%))<dither2|(SUCC(z%))),2) LET p2%=MUL(ABS(pic|(ADD(z%,2))<dither2|(ADD(z%,2))),4) LET p3%=MUL(ABS(pic|(ADD(z%,3))<dither2|(ADD(z%,3))),8) LET p4%=MUL(ABS(pic|(ADD(z%,4))<dither2|(ADD(z%,4))),16) LET p5%=MUL(ABS(pic|(ADD(z%,5))<dither2|(ADD(z%,5))),32) LET p6%=MUL(ABS(pic|(ADD(z%,6))<dither2|(ADD(z%,6))),64) LET p7%=MUL(ABS(pic|(ADD(z%,7))<dither2|(ADD(z%,7))),128) LET p8%=MUL(ABS(pic|(ADD(z%,8))<dither2|(ADD(z%,8))),256) LET p9%=MUL(ABS(pic|(ADD(z%,9))<dither2|(ADD(z%,9))),512) LET p10%=MUL(ABS(pic|(ADD(z%,10))<dither2|(ADD(z%,10))),1024) LET p11%=MUL(ABS(pic|(ADD(z%,11))<dither2|(ADD(z%,11))),2048) LET p12%=MUL(ABS(pic|(ADD(z%,12))<dither2|(ADD(z%,12))),4096) LET p13%=MUL(ABS(pic|(ADD(z%,13))<dither2|(ADD(z%,13))),8192) LET p14%=MUL(ABS(pic|(ADD(z%,14))<dither2|(ADD(z%,14))),16384) LET p15%=MUL(ABS(pic|(ADD(z%,15))<dither2|(ADD(z%,15))),32768) DPOKE word%,ADD(ADD(ADD(ADD(ADD(ADD(ADD(ADD(ADD(ADD(ADD(ADD(ADD(ADD(ADD(p0%,p1%),p2%),p3%),p4%),p5%),p6%),p7%),p8%),p9%),p10%),p11%),p12%),p13%),p14%),p15%) ADD word%,2 IF word%=scan% ADD word%,40 ADD scan%,80 ENDIF NEXT z% RETURN ' ' ' Load Sample Procedures ' ------------------------ ' > PROCEDURE load_sample(filename$) ' PURPOSE : identify sample file and branch to appropriate routine ' LET extender$=RIGHT$(filename$,3) ! NOTE: file extension DEFMOUSE iomouse$ OPEN "I",#1,filename$ IF extender$="AVR" GOSUB load_avr ELSE IF extender$="SND" GOSUB load_snd ELSE IF extender$="WAV" GOSUB load_wav ELSE IF extender$="DVS" GOSUB load_dvs ELSE ALERT 1,"Sample Format NOT recognised|at this time.",1," Cancel! ",void% CLOSE #1 LET head%(old_posit%,index%)=0 LET tail%(posit%)=0 LET file$(posit%)="FILENAME.TXT" LET type$(posit%)="" ENDIF DEFMOUSE 0 RETURN ' > PROCEDURE load_avr ' PURPOSE : load AVR sample, extract sample header and ' call external sample player module. ' LET header$=INPUT$(128,#1) CLOSE #1 IF LEFT$(header$,4)<>"2BIT" ALERT 2,"Invalid AVR-SAMPLE||Sample has incorrect file|extender.",1," Cancel! ",void% ELSE ' Sign Magnitude Yes/No IF DPEEK(VARPTR(header$)+16)=0 LET mag$=" " ELSE LET mag$=" -z" ENDIF ' Mono or Stereo Sample IF DPEEK(VARPTR(header$)+12)=0 LET st$=" " ELSE LET st$=" -2" ENDIF ' Hertz rate of sample LET hertz$=STR$(DPEEK(VARPTR(header$)+24)) ' Load and play sample LET buf$=" "+filename$+" "+hertz$+" -q"+mag$+st$ e%=EXEC(0,path$+"PLAY.EXE",CHR$(LEN(buf$))+buf$,"") ENDIF RETURN ' > PROCEDURE load_snd ' PURPOSE : load SND sample, extract sample header and ' call external sample player module. ' LET header$=INPUT$(28,#1) CLOSE #1 IF LEFT$(header$,4)<>".snd" ALERT 2,"Invalid SND-SAMPLE||Sample has incorrect file|extender.",1," Cancel! ",void% ELSE ' Sign Magnitude Yes/No LET mag$=" -z" ' Mono or Stereo Sample IF DPEEK(VARPTR(header$)+22)=1 LET st$="" ELSE LET st$=" -2" ENDIF ' Hertz rate of sample LET hertz$=STR$(DPEEK(VARPTR(header$)+18)) ' Load and play sample LET buf$=" "+filename$+" "+hertz$+" -q"+mag$+st$ e%=EXEC(0,path$+"PLAY.EXE",CHR$(LEN(buf$))+buf$,"") ENDIF RETURN ' > PROCEDURE load_wav ' PURPOSE : load WAV sample, extract sample header and ' call external sample player module. ' LET header$=INPUT$(44,#1) CLOSE #1 IF LEFT$(header$,4)<>"RIFF" ALERT 2,"Invalid WAVE-SAMPLE||Sample has incorrect file|extender.",1," Cancel! ",void% ELSE ' Sign Magnitude Yes/No LET mag$="" ' Mono or Stereo Sample IF PEEK(VARPTR(header$)+22)=1 LET st$="" ELSE LET st$=" -2" ENDIF ' Hertz rate of sample LET hertz$=STR$(PEEK(VARPTR(header$)+25)*256+PEEK(VARPTR(header$)+24)) ' Load and play sample LET buf$=" "+filename$+" "+hertz$+" -q"+mag$+st$ e%=EXEC(0,path$+"PLAY.EXE",CHR$(LEN(buf$))+buf$,"") ENDIF RETURN ' > PROCEDURE load_dvs ' PURPOSE : load DVSM sample, extract sample header and ' call external sample player module. ' LET header$=INPUT$(16,#1) CLOSE #1 IF LEFT$(header$,4)<>"DVSM" ALERT 2,"Invalid DVSM-SAMPLE||Sample has incorrect file|extender.",1," Cancel! ",void% ELSE ' Sign Magnitude Yes/No LET mag$=" -z" ' Mono or Stereo Sample IF PEEK(VARPTR(header$)+11)=0 OR PEEK(VARPTR(header$)+11)=1 LET st$=" -2" ELSE LET st$="" ENDIF ' Hertz rate of sample LET hertz$=STR$(freq%(DPEEK(VARPTR(header$)+8))) ' Load and play sample LET buf$=" "+filename$+" "+hertz$+" -q"+mag$+st$ e%=EXEC(0,path$+"PLAY.EXE",CHR$(LEN(buf$))+buf$,"") ENDIF RETURN ' ' ' Window Management Procedures ' ------------------------------ ' > PROCEDURE message ' PURPOSE : Handle Event Multi-Events. ' It handles window, mouse and menu events. ' IF MENU(1)>19 AND MENU(1)<29 LET handle&=MENU(4) ON MENU(1)-19 GOSUB wm_redraw,wm_topped,wm_closed,wm_fulled,wm_arrowed ON MENU(1)-24 GOSUB wm_hslid,wm_vslid,wm_sized,wm_moved ~WIND_GET(handle&,4,xx%,yy%,ww%,hh%) ON MENU IBOX 1,xx%,yy%,ww%,hh% GOSUB find_button ENDIF RETURN ' > PROCEDURE wm_closed ' PURPOSE : load previous window and prompt user to save current ' text window if modified. ' IF edited!=TRUE ALERT 1,"TEXT FILE MODIFIED!|Text File has been modified|but not saved!",2," Lose! | Save! ",but% LET edited!=FALSE IF but%=2 GOSUB esc_key ENDIF ENDIF SPRITE cursor$ IF posit%>1 LET posit%=tail%(posit%) SELECT type$(posit%) CASE "T" GOSUB load_text(file$(posit%)) CASE "S" GOSUB load_sample(file$(posit%)) CASE "G" GOSUB load_graphic(file$(posit%)) ENDSELECT ELSE ALERT 1,"At First Window|No previous window.",1," Ok! ",void% ENDIF RETURN ' > PROCEDURE wm_topped ' PURPOSE : top window, activate current window. ' LET handle&=MENU(4) ~WIND_SET(handle&,10,handle&,0,0,0) RETURN ' > PROCEDURE wm_moved ' PURPOSE : get moved windows new location co-ordinates. ' Move window and redraw contents. ' SPRITE cursor$ ~WIND_SET(handle&,5,MENU(5),MENU(6),MENU(7),MENU(8)) CLIP OFFSET MENU(5),MENU(6) GOSUB modwind(handle&,MENU(5),MENU(6),MENU(7),MENU(8)) GOSUB calc_slid(handle&) GOSUB do_redraw(0) RETURN ' > PROCEDURE wm_sized ' PURPOSE : get windows new width and height position. ' Set new window width and height position. ' If text window also reposition cursor, if ' location is now outside window co-ordinates. ' GOSUB draw_cursor(tpox%,tpoy%,FALSE) ~WIND_SET(handle&,5,MENU(5),MENU(6),MENU(7),MENU(8)) SELECT type$(posit%) CASE "T" GOSUB modwind(handle&,MENU(5),MENU(6),MIN(MENU(7),(xgrap%*chrbb%)+19),MIN(MENU(8),(ygrap%*chrbh%)+55)) GOSUB cursor_resize CASE "G" GOSUB modwind(handle&,MENU(5),MENU(6),MIN(MENU(7),xgrap%+19),MIN(MENU(8),ygrap%+55)) ENDSELECT LET wf!=FALSE RETURN ' > PROCEDURE cursor_resize ' PURPOSE : If the cursors current position is outside the ' current text window then it is repositioned inside ' the window. ' ~WIND_GET(handle&,4,x%,y%,b%,h%) GOSUB draw_cursor(tpox%,tpoy%,FALSE) IF cury%=>h%+y%-4 LET tpoy%=vpos%(posit%)+(h% DIV chrbh%) ELSE IF cury%<y% LET tpoy%=vpos%(posit%)+1 ENDIF IF curx%=>b%+x% LET tpox%=hpos%(posit%)+(b% DIV chrbb%) ELSE IF curx%<x% LET tpox%=hpos%(posit%)+1 ENDIF GOSUB draw_cursor(tpox%,tpoy%,FALSE) RETURN ' > PROCEDURE wm_fulled ' PURPOSE : resize window to fullsize or resize window to previous size. ' SPRITE cursor$ IF wf!=TRUE GOSUB store_size(FALSE,0,0,0,0) ~WIND_SET(handle&,5,xpos%(posit%),ypos%(posit%),wsiz%(posit%),hsiz%(posit%)) GOSUB modwind(handle&,xpos%(posit%),ypos%(posit%),wsiz%(posit%),hsiz%(posit%)) LET wf!=NOT wf! IF type$(posit%)="T" GOSUB cursor_resize ENDIF ELSE IF wf!=FALSE GOSUB store_size(TRUE,xpos%(posit%),ypos%(posit%),wsiz%(posit%),hsiz%(posit%)) LET wf!=NOT wf! LET xpos%(posit%)=scrx% LET ypos%(posit%)=scry% SELECT type$(posit%) CASE "T" LET wsiz%(posit%)=MIN(scrb%-4,(xgrap%*chrbb%)+19) LET hsiz%(posit%)=MIN(scrh%,(ygrap%*chrbh%)+55) CASE "G" LET wsiz%(posit%)=MIN(scrb%,xgrap%+19) LET hsiz%(posit%)=MIN(scrh%,ygrap%+55) ENDSELECT ~WIND_SET(handle&,5,xpos%(posit%),ypos%(posit%),wsiz%(posit%),hsiz%(posit%)) GOSUB modwind(handle&,xpos%(posit%),ypos%(posit%),wsiz%(posit%),hsiz%(posit%)) ENDIF RETURN ' > PROCEDURE store_size(store!,x%,y%,b%,h%) ' PURPOSE : stores windows current position and size or returns ' a windows previous window position and size. ' IF store!=TRUE LET storex%=x% LET storey%=y% LET storeb%=b% LET storeh%=h% ELSE LET xpos%(posit%)=storex% LET ypos%(posit%)=storey% LET wsiz%(posit%)=storeb% LET hsiz%(posit%)=storeh% ENDIF RETURN ' > PROCEDURE modwind(handle&,x%,y%,b%,h%) ' PURPOSE : modifies window width and height and slider positions. ' IF type$(posit%)="T" LET h%=ADD(MUL((h% DIV chrbh%),16),8) LET b%=ADD(MUL((b% DIV chrbb%),8),4) ENDIF ~WIND_SET(handle&,5,x%,y%,b%,h%) ~WIND_GET(handle&,4,x%,y%,b%,h%) SELECT type$(posit%) CASE "T" LET hpos%(posit%)=MIN(hpos%(posit%),xgrap%-b% DIV chrbb%) LET vpos%(posit%)=MIN(vpos%(posit%),ygrap%-h% DIV chrbh%) CASE "G" LET hpos%(posit%)=MIN(hpos%(posit%),SUB(xgrap%,b%)) LET vpos%(posit%)=MIN(vpos%(posit%),SUB(ygrap%,h%)) ENDSELECT ~WIND_GET(handle&,5,xpos%(posit%),ypos%(posit%),wsiz%(posit%),hsiz%(posit%)) GOSUB calc_slid(handle&) RETURN ' ' ' Window Sliders Procedures ' --------------------------- ' > PROCEDURE calc_slid(handle&) ' PURPOSE : calculates new slider size and position. ' ~WIND_GET(handle&,4,x%,y%,b%,h%) SELECT type$(posit%) CASE "T" IF vpos%(posit%)<>0 AND h%/chrbh%<ygrap% ~WIND_SET(handle&,9,vpos%(posit%)/(ygrap%-h%/chrbh%)*1000+0.5,0,0,0) ELSE IF h%/chrbh%=>ygrap% OR vpos%(posit%)=0 ~WIND_SET(handle&,9,1,0,0,0) ENDIF LET barv%=h%/ygrap%/chrbh%*1000+0.5 IF barv%>0 AND barv%<1001 AND h%/chrbh%<ygrap% ~WIND_SET(handle&,16,barv%,0,0,0) ELSE ~WIND_SET(handle&,16,1000,0,0,0) ENDIF CASE "G" GOSUB set_slid(handle&,b%/xgrap%,h%/ygrap%,hpos%(posit%)/SUB(xgrap%,b%),vpos%(posit%)/SUB(ygrap%,h%)) ENDSELECT RETURN ' > PROCEDURE set_slid(handle&,hs,vs,hp,vp) ' PURPOSE : sets a windows slider position and size. ' ~WIND_SET(handle&,15,hs*1000+0.5,0,0,0) ~WIND_SET(handle&,16,vs*1000+0.5,0,0,0) ~WIND_SET(handle&,8,hp*1000+0.5,0,0,0) ~WIND_SET(handle&,9,vp*1000+0.5,0,0,0) RETURN ' > PROCEDURE wm_hslid ' PURPOSE : gets a windows horizontal slider bars new position. ' ~WIND_GET(handle&,4,x%,y%,b%,h%) SELECT type$(posit%) CASE "G" LET hpos%(posit%)=MUL(MENU(5),SUB(xgrap%,b%))/1000+0.5 ENDSELECT GOSUB calc_slid(handle&) GOSUB do_redraw(0) RETURN ' > PROCEDURE wm_vslid ' PURPOSE : gets a windows vertical slider bars new position. ' ~WIND_GET(handle&,4,x%,y%,b%,h%) SELECT type$(posit%) CASE "T" LET vpos%(posit%)=MUL(MENU(5),SUB(ygrap%,DIV(h%,chrbh%)))/1000+0.5 GOSUB cursor_resize CASE "G" LET vpos%(posit%)=MUL(MENU(5),SUB(ygrap%,h%))/1000+0.5 ENDSELECT GOSUB calc_slid(handle&) GOSUB do_redraw(0) RETURN ' > PROCEDURE wm_arrowed ' PURPOSE : determines which window type arrows have been moved ' and branches to the appropriate procedure. ' ~WIND_GET(handle&,4,x%,y%,b%,h%) SELECT type$(posit%) CASE "T" GOSUB arrow_text CASE "G" GOSUB arrow_graphic ENDSELECT RETURN ' > PROCEDURE arrow_text ' PURPOSE : updates a text windows contents according to a arrow button ' event or before or after slider bar event. ' SELECT MENU(5) CASE 0 ! move screen down complete window size position. LET vpos%(posit%)=MAX(SUB(vpos%(posit%),DIV(h%,chrbh%)),0) GOSUB cursor_resize GOSUB calc_slid(handle&) GOSUB do_redraw(0) CASE 1 ! move screen up complete window size position. LET vpos%(posit%)=MIN(ADD(vpos%(posit%),DIV(h%,chrbh%)),SUB(ygrap%,DIV(h%,chrbh%))) GOSUB cursor_resize GOSUB calc_slid(handle&) GOSUB do_redraw(0) CASE 2 ! move screen down one line or cursor down one line. GOSUB up_key GOSUB draw_cursor(tpox%,tpoy%,TRUE) CASE 3 GOSUB down_key ! move screen up one line or cursor up one line. GOSUB draw_cursor(tpox%,tpoy%,TRUE) ENDSELECT RETURN ' > PROCEDURE arrow_graphic ' PURPOSE : updates a graphic windows contents according to a arrow button ' event or before or after slider bar event. ' SELECT MENU(5) CASE 0 ! move screen down one complete window size position. LET vpos%(posit%)=MAX(SUB(vpos%(posit%),h%),0) CASE 1 ! move screen up one complete window size position. LET vpos%(posit%)=MIN(ADD(vpos%(posit%),h%),SUB(ygrap%,h%)) CASE 2 ! move screen down 10 pixels. LET vpos%(posit%)=MAX(SUB(vpos%(posit%),10),0) CASE 3 ! move screen up 10 pixels. LET vpos%(posit%)=MIN(ADD(vpos%(posit%),10),SUB(ygrap%,h%)) CASE 4 ! move screen right one complete window size position. LET hpos%(posit%)=MAX(SUB(hpos%(posit%),b%),0) CASE 5 ! move screen left one complete window size position. LET hpos%(posit%)=MIN(ADD(hpos%(posit%),b%),SUB(xgrap%,b%)) CASE 6 ! move screen right 10 pixels. LET hpos%(posit%)=MAX(SUB(hpos%(posit%),10),0) CASE 7 ! move screen left 10 pixels. LET hpos%(posit%)=MIN(ADD(hpos%(posit%),10),SUB(xgrap%,b%)) ENDSELECT GOSUB calc_slid(handle&) GOSUB do_redraw(0) RETURN ' ' ' Window Redraw Procedures ' -------------------------- ' > PROCEDURE do_redraw(do_line%) ' PURPOSE : prepare window for redraw by getting windows size. ' ~WIND_GET(handle&,4,w1%,w2%,w3%,w4%) GOSUB xredraw(w1%,w2%,w3%,w4%) RETURN ' > PROCEDURE wm_redraw ' PURPOSE : get multi events first windows clip rectangle. ' GOSUB xredraw(MENU(5),MENU(6),MENU(7),MENU(8)) RETURN ' > PROCEDURE xredraw(m5%,m6%,m7%,m8%) ' PURPOSE : is there any more clip rectangles and if there are ' get clip rectangle size. ' ~WIND_UPDATE(1) ! hide mouse ~WIND_GET(handle&,11,w1%,w2%,w3%,w4%) WHILE w3% OR w4% LET tb%=ADD(w1%,w3%) LET th%=ADD(w2%,w4%) LET tx%=MAX(w1%,m5%) LET ty%=MAX(w2%,m6%) LET tb%=SUB(MIN(tb%,ADD(m5%,m7%)),tx%) LET th%=SUB(MIN(th%,ADD(m6%,m8%)),ty%) IF tb%>0 AND th%>0 GOSUB redraw(handle&,tx%,ty%,tb%,th%) ENDIF ~WIND_GET(handle&,12,w1%,w2%,w3%,w4%) WEND ~WIND_UPDATE(0) ! redraw mouse RETURN ' > PROCEDURE redraw(handle&,x%,y%,b%,h%) ' PURPOSE : identify type of window and clip window before redraw. ' IF b%>SUB(scrb%,x%) LET b%=SUB(scrb%,x%) ENDIF ~WIND_GET(handle&,4,w1%,w2%,w3%,w4%) CLIP x%,y%,b%,h% OFFSET w1%,w2% SELECT type$(posit%) CASE "T" GOSUB redraw_text CASE "G" GOSUB redraw_graphic ENDSELECT RETURN ' > PROCEDURE redraw_line ' PURPOSE : redraw text line. ' IF tpoy%>=0 ~WIND_GET(handle&,4,w1%,w2%,w3%,w4%) CLIP x%,y%,b%,h% OFFSET w1%,w2% TEXT -MUL(hpos%(posit%),chrbb%),ADD(SUB(cury%,y%),13),txt$(PRED(tpoy%))+SPACE$(80) ENDIF RETURN ' > PROCEDURE redraw_text ' PURPOSE : redraw complete text window. ' IF do_line%=1 GOSUB redraw_line ELSE IF vpos%(posit%)<0 LET vpos%(posit%)=0 ENDIF PBOX -2,-2,999,999 CLIP x%,y%,b%,h% OFFSET w1%,w2% FOR line%=0 TO (h% DIV chrbh%) TEXT -MUL(hpos%(posit%),chrbb%),ADD(MUL(line%,chrbh%),13),txt$(ADD(line%,vpos%(posit%))) NEXT line% GOSUB draw_button ENDIF GOSUB draw_cursor(tpox%,tpoy%,TRUE) GOSUB wind_title(handle&," Text Window ") GOSUB wind_info(handle&,"Col:"+STR$(tpox%)+" Row:"+STR$(tpoy%)+" "+insert$) RETURN ' > PROCEDURE redraw_graphic ' PURPOSE : redraw complete graphic window. ' LET p%(0)=SUB(ADD(hpos%(posit%),x%),w1%) LET p%(1)=SUB(ADD(vpos%(posit%),y%),w2%) LET p%(2)=PRED(ADD(p%(0),b%)) LET p%(3)=PRED(ADD(p%(1),h%)) LET p%(4)=x% LET p%(5)=y% LET p%(6)=PRED(ADD(x%,b%)) LET p%(7)=PRED(ADD(y%,h%)) LET p%(8)=3 LET smfdb%(0)=VARPTR(raster$) BITBLT smfdb%(),dmfdb%(),p%() GOSUB draw_button RETURN ' ' ' Miscellanous Window Procedures ' -------------------------------- ' > FUNCTION generate_handle(attr&) ' PURPOSE : generate new window handle and storage space. ' hand&=WIND_CREATE(attr&,scrx%,scry%,scrb%,scrh%) IF hand&=-1 ALERT 1,"TOO MANY OPEN WINDOW!|Try closing some windows!",1," Damn! ",void% ENDIF RETURN hand& ENDFUNC ' > PROCEDURE open_window(type$) ' PURPOSE : open window and prepare title and info line. ' ~WIND_UPDATE(1) GOSUB close_old(handle&) LET type$(posit%)=type$ SELECT type$ CASE "G" LET handle&=FN generate_handle(CARD(4095)) GOSUB wind_title(handle&," Graphics Window ") CASE "T" LET handle&=FN generate_handle(CARD(511)) GOSUB wind_title(handle&," Text Window ") ENDSELECT GOSUB wind_info(handle&,file$(posit%)+" "+STR$(posit%)) ~WIND_OPEN(handle&,xpos%(posit%),ypos%(posit%),wsiz%(posit%),hsiz%(posit%)) GOSUB calc_slid(handle&) ~WIND_UPDATE(0) RETURN ' > PROCEDURE close_old(handle&) ' PURPOSE : closes an existing window and deallocates its memory ' and frees its handle. ' IF handle&>0 GOSUB draw_cursor(tpox%,tpoy%,FALSE) ~WIND_CLOSE(handle&) ~WIND_DELETE(handle&) ENDIF RETURN ' > PROCEDURE wind_title(handle&,title$) ' PURPOSE : sets a windows title bar. ' LET title$=title$+CHR$(0) LET title%=V:title$ ~WIND_SET(handle&,2,CARD(SWAP(title%)),CARD(title%),0,0) RETURN ' > PROCEDURE wind_info(handle&,info$) ' PURPOSE : sets a windows information line. ' LET info$=info$+CHR$(0) LET info%=V:info$ VSYNC ~WIND_SET(handle&,3,CARD(SWAP(info%)),CARD(info%),0,0) RETURN ' > PROCEDURE get_textsize(VAR chrb%,chrh%,chrbb%,chrbh%) ' PURPOSE : gets the systems current font size and type. ' LET v%=CONTRL(6) GEMSYS 77 CONTRL(6)=GINTOUT(0) VDISYS 38 CONTRL(6)=v% LET chrb%=PTSOUT(0) LET chrh%=PTSOUT(1) LET chrbb%=PTSOUT(2) ! Text Width pixels LET chrbh%=PTSOUT(3) ! Text Height pixels DEFTEXT 1,0,0,chrh%,1 RETURN