' ######################################################################### ' ## ## ' ## Program : "EdWord" Text Editor ## ' ## Version : V4.1 (Professional) ## ' ## Author : Martin Reddy ## ' ## Date : 26/8/92 ## ' ## Credits : Hi there Mum ! ## ' ## Purpose : To produce a decent text editor which is used primarily ## ' ## as a language text editor thus supporting features like ## ' ## AutoIndent, Text Keyword Casing, Access to AmigaDOS for ## ' ## such operations as compilations etc. ## ' ## Updates : V1.0 was written in 68000 but was left incomplete due ## ' ## to long program development time ## ' ## V2.0 written in GFA-Basic using arrays - worked okay ## ' ## but not good at memory management ## ' ## V2.1 GFA code re-written in terms of memory addresses ## ' ## instead of arrays (basically using the GFA-Basic ## ' ## interpreter to program 68000 speedily) ## ' ## V2.1b Major bug fix plus new options added also some ## ' ## code rewritten in machine code to speed things up ## ' ## V2.2 Updated code & interface for Workbench 2.0 ## ' ## Released as a shareware product 7/3/92 ## ' ## V2.3 the Registered-user's version. Features more ## ' ## powerful facilities and general speed-ups ## ' ## V3.0 With addition of PowerPacker routines, a Split ## ' ## screen facility and fully-featured calculator, I ## ' ## bumped the version number up - 13/7/92 ## ' ## V3.1 ARexx port, improved casing + user commands and ## ' ## now uses RawKeyConvert() with RAWKEY messages. ## ' ## V4.0 Macros, Full use of Intuition, AutoSuggest - All ## ' ## in all one shit-hot program! ## ' ## V4.1 Now EdWord Professional: Up to 15 documents at ## ' ## once, ARexx port, macro facility etc. (15/9/93) ## ' ## ## ' ######################################################################### ' $M60000 ' DEFINT "a-Z" initialise WHILE NOT buggeroff! update_time update_title_bar wait_for_editor_event mouse_hit test_keypress do_you_really_wanna_quit(buggeroff!) time_save WEND close_down EDIT ' ******************* INITIALISE AND CLEAN-UP SUBROUTINES ******************* > PROCEDURE close_down ' ' Redirects any DOS requesters back to the WorkBench screen, ' Returns any allocated memory back to the system, closes ' any fonts which were used and restores the workbench colours ' to their original state in case they were changed by the ' program. ' FOR loop%=0 TO max_docs%-1 IF docstart%(loop%)<>0 THEN ! release all document memory ~FreeMem(docstart%(loop%),memorysize%(loop%)) ENDIF NEXT loop% ' IF linebuffer%<>0 THEN ! Deleted line buffer (^Y) ~FreeMem(linebuffer%,linebuffersize%) ENDIF ' IF clipstart%<>0 AND clipsize%<>0 THEN ! Cut/Copied Block ~FreeMem(clipstart%,clipsize%) ENDIF ' IF undobuffer%<>0 THEN ! The undo buffer memory ~FreeMem(undobuffer%,undosize%) ENDIF ' IF macromemory%<>0 THEN ! Free memory for macro list ~FreeMem(macromemory%,macrosize%*maxmacros%) ENDIF ' IF arpbase%<>0 THEN ~CloseLibrary(arpbase%) ENDIF ' IF aslbase%<>0 THEN deallocate_asl ENDIF ' IF busypointer%<>0 THEN ~FreeMem(busypointer%,73) ENDIF ' restore_workbench_colours forget_ascii_screen close_screen close_console_device close_timer close_font close_arexx ' IF mc68000installmenus%<>0 THEN ~FreeMem(mc68000installmenus%,8900) ENDIF ' IF appwindowport%<>0 THEN ! Remove App Window Msg Port ~DeletePort(appwindowport%) ENDIF ' IF workbenchbase%<>0 THEN ~CloseLibrary(workbenchbase%) ! Close the workbench.library ENDIF ' RETURN > PROCEDURE initialise ' ' Sets up the initial screen display, variables etc ' ' This is were it all begins .... exciting isn't it !! ' ' ON ERROR GOSUB error_handler ' INLINE versionstring%,46 INLINE pubscreenname%,20 ' buggeroff!=FALSE open_console_device initialise_colours initialise_arrays install_mcode check_for_workbench2.0 ' wbenchstart!=(Output()=0) author$="_w"+CHR$(31)+"Mbtwms&Ymmn"+CHR$(132) author2$="J,Qeef|" version$="4.1" oldconfigheader$="EdWord Configuration File - M.Reddy 1991." configheader$="EdWord V4.0 Configuration File - M.Reddy 1993." configfile$="EdWord.config" screenname$="EdWord Pro V"+version$ decode(author$) decode(author2$) curfilename$="" deffont$="topaz" deffont%=0 check_for_ntsc ' get_mounted_drives allocate_asl ' default_config install_case_tables check_command_tail IF NOT buggeroff! THEN reset_variables install_multidocs open_arexx open_timer ' ' open the workbench.library and a MsgPort for AppWindow support ' workbenchname$="workbench.library"+CHR$(0) workbenchbase%=OpenLibrary(V:workbenchname$,37) appwindowport%=CreatePort(0,0) ' @load_font IF NOT buggeroff! THEN memorysize%=memorysize%+memlow% allocate_doc_mem IF NOT buggeroff! THEN check_for_pubscreen open_screen IF NOT buggeroff! THEN ' install_busy_pointer @load_initial_file ' ' Use the -REQ command line option to force a recquester on start up ' IF forcerequester! AND exist%>=0 THEN open_file ENDIF ' ' Use the -L command line option to jump straight to a line no. ' IF immediate_jump! THEN goto_line(VAL(jump_line$),TRUE,TRUE) update_line update_column ENDIF ' IF use_wbench! THEN wbench_colours_changed!=colours_changed! ENDIF ' cursor_on check_for_virus check_todays_date ' ' use the -AREXX command line option to run an ARexx script ' IF initial_arexx! THEN send_rexx_command(initial_arexx$) ENDIF ' ' Check for -ZOOM command line option to immediately iconify ' IF force_zoom! THEN force_zoom!=FALSE clear_registers reg%(8)=winptr%(0) reg%(14)=_IntBase RCALL _IntBase-&H1F8,reg%() ENDIF ' ENDIF ENDIF ENDIF ENDIF RETURN > PROCEDURE initialise_colours ' ' Defines the default colours and which colours are used as pens which ' are used for backgrounds, which are used for shadows etc. ' DIM colour%(3,2),wbcolour%(3,2),oldcolour%(3,2) ' col0%=0 col1%=1 col2%=2 col3%=3 ' backcol%=col3% pen1col%=col1% pen2col%=col2% shadow1%=col2% shadow2%=col1% ' get_default_screen_colours ! Set up the default colours ensure_embossed(shadow1%,shadow2%) ! Ensure that shadows fall down-right ' backcol_old%=backcol% pen1col_old%=pen1col% pen2col_old%=pen2col% shadow1_old%=shadow1% shadow2_old%=shadow2% updatepencolours RETURN > PROCEDURE initialise_arrays ' ' Yeuch! horrible things!!! ' maxfiles%=100 ! Maximum no. of files in file requester maxreqs%=2 ! Maximum no. of file requester buffers ctrl_c!=FALSE ' DIM fkey$(10),keyword$(1),delimopen$(20),delimclose$(20),newsizegadget%(3) DIM delrange%(20,1),table$(maxfiles%),entrysize%(maxfiles%),mark%(2,2) ' DIM reqname$(maxfiles%,maxreqs%),reqsize%(maxfiles%,maxreqs%),bytesfree%(maxreqs%),pattern$(maxreqs%) DIM newdir!(maxreqs%),thefile$(maxreqs%),path$(maxreqs%),nooffiles%(maxreqs%) DIM topdir%(maxreqs%),indent_sy$(20),unindent_sy$(20),arexx_script$(10) DIM drive$(4),winptr%(5),scrptr%(1),split%(2),maxrow%(2),text_offset%(2) ' DIM command$(2),autosave!(2),delay!(2),customwin!(2),commenu$(2) DIM winwidth%(4),winheight%(4),wintitle%(4),statusgadget%(8,1),sysgad%(2,3) DIM temptable$(maxfiles%),tempentrysize%(maxfiles%),number(2),reg%(16) ' DIM okay%(3),cancel%(3),reqokay%(3),reqcancel%(3),okay2%(3),cancel2%(3) DIM gad0%(3),gad1%(3),gad2%(3),gad3%(3),gad4%(4),gad5%(3),gad6%(3),co1%(3) DIM okgad%(3),cancgad%(3),df0%(3),df1%(3),df2%(3),dh0%(3),ram%(3),parent%(3) DIM h%(3),s%(3),p%(3),a%(3),r%(3),w%(3),e%(3),d%(3),temparray%(3),pen%(4) DIM nlq%(3),man%(3),pnos%(3),pitch%(3),wrap%(3),eject%(3),attr%(1) DIM status%(3),text$(20),argv$(4),level$(20),invert%(3) ' INLINE myscreenfont%,25 IF myscreenfont%<>0 THEN ' ' also set up a TextAttr structure from my screen font (topaz 80) ' LPOKE myscreenfont%,myscreenfont%+10 ! Ptr to font name DPOKE myscreenfont%+4,8 ! Font Size POKE myscreenfont%+6,0 ! Style=FS_NORMAL POKE myscreenfont%+7,1 ! Flags=FPF_ROMFONT topazname$="topaz.font"+CHR$(0) BMOVE V:topazname$,myscreenfont%+10,LEN(topazname$) ENDIF ' RETURN > PROCEDURE get_mounted_drives ' ' assign(mountedlist$) mountedlist$=UPPER$(mountedlist$) ' IF workbench_2.0! THEN IF INSTR(mountedlist$,"PROGDIR:")<>0 THEN ! then check PROGDIR: defaultdir$="PROGDIR:" ENDIF ENDIF get_path_string(defaultdir$) ' RETURN > PROCEDURE reset_variables ' ' Initialises all the variables and flags which EdWord needs, initialises ' the menu table data, loads a configuration file (if there) and a few ' other sundry little details to stop the thing crashing !! - Software ' Engineering principles eh! ' ' answer_to_life_the_universe_and_everything=42 ! Very important !!! ' ' indent, maxcol etc. defined in OpenScreen() ' maxint%=2147483647 curline%=1 ! Current text line 1..NoOfLines nooflines%=1 ! Number of lines in the document noofchars%=1 ! No of characters/bytes in document indent%=0 ! Left/Right screen indenting cursorx%=0 ! Cursor position in screen 0..MaxCol cursory%=0 ! Cursor position in screen 0..MaxRow textmode%=0 ! 0=INSERT,1=DESTROY cliplines%=0 ! Number of lines in the clipboard blockstart%=0 ! Line number of block start, 0=none blockend%=0 ! Line number of block end, 0=none keywords%=0 ! Number of keywords loaded scrollsize%=40 ! The amount scrolled left/right memlow%=500 ! Low-memory limit maxlines%=10000 ! Maximum number of lines in text maxmacros%=640 ! Maximum number of macro events macrosize%=16 ! Size of a single macro event (bytes) pixel_offset%=ABS(workbench_2.0!) ! For WBench 2.0 title bar sizes text_offset%=0 ! For Split Screen facility linebuffer%=0 ! Start address of deleted line (^Y) linebuffersize%=0 ! No of bytes in the deleted line clipstart%=0 ! Memory address of copied block clipsize%=0 ! Size of copied block in bytes ignore%=0 ! semaphore to ignore OS messages lf%=10 ! Line Feed character = CHR$(10) tab%=9 ! Tab Character = CHR$(9) undobuffer%=0 ! Start of undo text for line undosize%=0 ! No of bytes in undo buffer abyss%=0 ! Size of buffer space at EOLn timedelay%=0 ! Time delay for ignoring events rawkey%=12577793 ! Hardware keyboard register clock%=&HBFE801 ! Hardware timer register mode_old%=1005 ! For the dos.library Open() mode_new%=1006 ! For the dos.library Open() menuon%=82 ! Menu command to invert menu item menuoff%=66 ! Menu command to ghost menu item currwindow%=-1 ! Number of currently activated window currscreen%=0 ! 0=WBench,1=Custom repeatcount%=8 ! Default count for Repeat Text macromemory%=0 ! No memory allocate for macros yet fmaxpot%=60 ! size of file requester prop gadget fproppos=0 ! File requester prop gadget position fpropsize=1 ! File requester prop gadget size cmaxpot%=38 ! size of text casing prop gadget cproppos=0 ! text casing prop gadget position cpropsize=1 ! text casing prop gadget size keypos%=0 ! Initial top position for case prop defaultkeycase%=1 ! Default keywordcase on setting resizes%=0 ! Number of resizes (zooms) nil%=0 ! A Nil pointer value last_mouse_timer=TIMER ! Initial start point for double click ctrl_c!=FALSE ! CTRL+C is not currently depressed dosstart!=TRUE ! Was started from DOS or WorkBench? forward!=TRUE ! Searches are forward by default fromtop!=FALSE ! Searches start from top of doc casedep!=FALSE ! Case Dependancy for searches blockon!=FALSE ! Is there a block specified? blockcopied!=FALSE ! Has a block been copied yet? in_gadget!=FALSE ! Set to true when in a string gadget ascendsort!=TRUE ! Ascending or Descending sort? keywordsloaded!=FALSE ! True if keyword file loaded in memry wbench_colours_changed!=FALSE ! True if user changes colours on wbench colours_changed!=FALSE ! True if user changes colours at all LET double_click!=FALSE ! True when LMB is double clicked lineupdated!=FALSE ! True if current line has been changed docupdated!=FALSE ! True if document has been changed globalcase!=FALSE ! Set if entire document is cased lineoverflow!=FALSE ! Set when cursor position beyond EOL mouse!=FALSE ! TRUE when mouse button clicked prop_hit!=FALSE ! set when the prop gadget is hit hide_cursor!=FALSE ! Controls cursor upon open_window quick_refresh!=FALSE ! Detect keypresses during refresh? recording_macro!=FALSE ! We are not currently recording a macro playing_macro!=FALSE ! Nor are we playing one firstdir!=TRUE ! First time requester used arexx_hotkey!=TRUE ! Can use CTRL+F1..F10 for scripts last_time_save%=TIMER ! Time when last Time Save performed undo$="" ! String with initial line text find$="" ! The current search string findhex$="" ! The current hex search string findreplace$="" ! The current replace string repeattext$="" ! Text for the Repeat Text option setup$="" ! Printer initialising hex string offset$="1" ! Offset characters for Sort routine pageno_symbol$="%p" ! Symbol used to represent a page no. confirm$="OKAY" ! Text used for okay gadgets accept$="ACCEPT" ! Text used for accept gadgets cancel$="CANCEL" ! Text used for cancel gadgets blank_line$=SPACE$(80) ! Used for the RefreshLine() routine topazptr%=0 ! Clear the topaz font pointer mark%(0,0)=0 ! | mark%(1,0)=0 ! |- Clear all initial jump marks mark%(2,0)=0 ! | ' ' ***** LOAD A CONFIGURATION FILE IF NECESSARY ****** ' (From current directory or ENV:) ' get_printer_defaults path$=defaultdir$ ! Current path append_filename(configdir$,configfile$,tempfile$) ' env_mounted!=TRUE IF NOT no_configfile! THEN file_type(tempfile$,x%) IF x%>=0 THEN ! IF configfile not in curr dir IF INSTR(mountedlist$,"ENV:")<>0 THEN ! then check ENV: append_filename("ENV:EdWord/",configfile$,tempfile$) file_type(tempfile$,x%) IF x%<0 THEN configdir$="ENV:EdWord/" ENDIF ELSE env_mounted!=FALSE ENDIF ENDIF ' IF x%<0 THEN @load_config_file(configdir$) ENDIF ENDIF ' ' Now look at the command line options... ' use_command_tail set_alternate_cursor ' ' Initialise all the file requester buffer areas ' disk_space(bytes%) FOR tracy%=0 TO maxreqs% newdir!(tracy%)=NOT nodir! ! Do we need to update directory list? topdir%(tracy%)=1 ! top entry in file requester bytesfree%(tracy%)=bytes% pattern$(tracy%)=pattern$ NEXT tracy% ' ' Test to see if run from WorkBench ... ' IF Input()=0 OR Output()=0 OR xicon! THEN FOR clare%=0 TO 2 customwin!(clare%)=TRUE NEXT clare% dosstart!=FALSE ENDIF @save_old_colours ' ' **** ACCOUNT FOR -NTSC COMMAND LINE OPTION **** ' IF force_ntsc! OR ntscamiga! THEN ! Forced into NTSC by command line IF screenres%>300 THEN screenres%=400 ELSE screenres%=200 ENDIF ENDIF ' ' **** ACCOUNT FOR -WB COMMAND LINE OPTION **** ' IF force_wbench! THEN ! Forced onto WBench by command line use_wbench!=TRUE IF screenres%>300 THEN screenres%=screenres%/2 ! If WBench, then no interlace ENDIF ENDIF ' ' **** ACCOUNT FOR -LACE COMMAND LINE OPTION **** ' IF force_lace! THEN screenres%=screenres%*2 use_wbench!=FALSE ENDIF ' ' **** ACCOUNT FOR -MEM COMMAND LINE OPTION **** ' IF usermem! THEN IF VAL(memorysize$) PROCEDURE load_initial_file ' ' ** LOAD FILE SPECIFIED IN COMMAND LINE ** ' exist%=0 IF commandtail$<>"" THEN filename$=commandtail$ ' ' If the device is mounted, then proceed as okay ' split_filename(filename$,path$,thefile$) FOR michelle%=0 TO maxreqs% path$(michelle%)=path$ thefile$(michelle%)=thefile$ NEXT michelle% ' file_type(filename$,exist%) IF exist%<0 THEN ! load file if it exists @load_data ELSE IF exist%=0 @load_data ! Won't work - "file not found!" curfilename$=filename$ window_title(0,"") ENDIF ENDIF RETURN > PROCEDURE allocate_doc_mem ' ' Allocates the memory buffer for all text to be stored in ' And initialises the document position memory addresses. ' FALSE_EOF! is TRUE if a file is loaded which has no Line Feed at EOF ' docstart%=AllocMem(memorysize%,1) IF docstart%=0 OR AvailMem(&H20000)<=2048 THEN inform("Not Enough Memory for default buffer size!|(Largest Contiguous Memory = "+STR$(AvailMem(&H20000))+" bytes)") buggeroff!=TRUE ELSE lineadd%=docstart% curradd%=docstart% topadd%=docstart% POKE docstart%,lf% false_eof!=FALSE hide_cursor!=TRUE ENDIF RETURN > PROCEDURE init_prop ' ' Draws the outline of the proportional gadget and defines its ' initial values then draws the gadget itself. The prop gagdet on a ' workbench screen is position slightly more to the left than on ' a custom screen (as there are 76 columns of text instead of 77). This ' is the reason for the `+(use_wbench!*8)' part of the coords. ' This procedure also draws the two scroll gadgets which appear as arrows ' to the top and bottom of the proportional gadget. ' LOCAL px1%,px2% ' px1%=screenwidth%-21 px2%=screenwidth%-2 prop_offset%=ABS(use_wbench!)*pixel_offset% draw_box(0,px1%+(use_wbench!*8),10+prop_offset%,px2%+(use_wbench!*8),bottomline%-11) maxpot%=bottomline%-25-prop_offset% ! size of the proportional gadget proppos=0 propsize=1 update_prop ' up_scroll_arrow(0,px1%-1+(use_wbench!*8),prop_offset%) dn_scroll_arrow(0,px1%-1+(use_wbench!*8),maxpot%+16+prop_offset%) ' ' >>> DEFINE THE UP/DOWN ARROWS BOUNDARIES (FOR GADGET DETECTION) <<< ' sysgad%(1,0)=px1%-4+(use_wbench!*8) sysgad%(1,1)=prop_offset% sysgad%(1,2)=px2%+4+(use_wbench!*8) sysgad%(1,3)=8+prop_offset% ' sysgad%(2,0)=px1%-4+(use_wbench!*8) sysgad%(2,1)=maxpot%+16+prop_offset% sysgad%(2,2)=px2%+4+(use_wbench!*8) sysgad%(2,3)=maxpot%+24+prop_offset% RETURN > PROCEDURE attach_menus ' ' Attachs the EdWord menus to the editor window ' IF winptr%(0)<>0 AND mc68000installmenus%<>0 THEN clear_registers reg%(8)=winptr%(0) reg%(14)=_IntBase RCALL mc68000installmenus%,reg%() menu_strip%=reg%(8) ' menu_attr(1,18,150) menu_text(5,6,commenu$(0)) menu_text(5,7,commenu$(1)) menu_text(5,8,commenu$(2)) ENDIF RETURN > PROCEDURE open_screen ' ' Opens a custom screen and window and draws the prop gagdet and ' status line. 6 modes of screen resolution are possible. Refer ' to NEWSCREENMODE for more on these. Checks are made to see that ' enough memory is available for the operation, if this is not the ' case, then an appropriate message will be displayed and the user is ' given the apportunity to revert to the smallest resolution or to ' quit the editor. ' ' 1) If CUSTOM_SIZE! is true, then CUSTOM_SIZE pixels will be used for window ' 2) WINDOW_YCOORD defines the y-coordinate of the window/screen ' 2) WINDOW_XCOORD defines the x-coordinate of the window/screen ' ' N.B. CUSTOM_SIZE! and WINDOW_YCOORD are reset at the end of this routine. ' LOCAL ram_needed%,ram_error!,newscreenres% ' IF custom_size! THEN newscreenres%=MAX(MIN(custom_size%,screenres%),100) bottomline%=newscreenres%-24 IF NOT use_wbench! THEN IF wbench_interlace! AND newscreenres%<400 THEN newscreenres%=MAX(newscreenres%,wbench_size% DIV 2) ELSE newscreenres%=MAX(newscreenres%,wbench_size%) ENDIF ENDIF ELSE newscreenres%=screenres% bottomline%=newscreenres%-24 ENDIF ' IF NOT use_wbench! THEN screenwidth%=640 ENDIF ' maxrow%=bottomline% DIV 8 custom_size!=FALSE ram_error!=FALSE rastport%=0 IF newscreenres%<400 THEN screenmode%=&H8000 ELSE screenmode%=&H8004 ENDIF ' message("") ' ' Find out the height of the WorkBench screen's title bar ' wbscrdata$=STRING$(346,CHR$(0)) wbscrdata%=V:wbscrdata$ ~GetScreenData(wbscrdata%,44,1,0) scrbarheight%=PEEK(wbscrdata%+35)+DPEEK({wbscrdata%+40}+4)+1 wbscrwidth%=DPEEK(wbscrdata%+12) screenwidth%=MIN(MAX(screenwidth%,100),wbscrwidth%) window_xcoord%=MIN(window_xcoord%,wbscrwidth%-screenwidth%) ' IF use_wbench! THEN window_ycoord%=MIN(MAX(window_ycoord%,0),screenres%-bottomline%-24) ~WBenchToFront() ' ' Set up a NewWindow structure ... (48 bytes) ' aimee$=STRING$(80,CHR$(0)) newwindow%=V:aimee$ ' ' Define the x,y position of the ' window and its width & height ' DPOKE newwindow%,window_xcoord% DPOKE newwindow%+2,window_ycoord% DPOKE newwindow%+4,screenwidth% DPOKE newwindow%+6,bottomline%+24 ' ' Define the Detail Pen and ' Block Pen colours ' POKE newwindow%+8,0 POKE newwindow%+9,1 ' ' Define the IDCMP flags to react ' to, and the display flags, and ' store a pointer to the title. ' (WFLG_NW_EXTENDED=$40000) ' ' WorkBench Editor Window IDCMP Flags = ' ' MOUSEBUTTONS + RAWKEY + MENUPICK + CLOSEWINDOW + INTUITICKS ' NEWSIZE + INACTIVEWINDOW ' LPOKE newwindow%+10,&H708+&H400000+&H2+&H80000 LPOKE newwindow%+14,&H100E+&H40000 LPOKE newwindow%+26,windownamebuffer% ' ' State the screen to display the ' window on. 0=use WorkBench screen. ' The Type field is set to CUSTOMSCREEN ' or WBENCHSCREEN accordingly ' LPOKE newwindow%+30,0 DPOKE newwindow%+46,1 ' ' Do the WorkBench 2.0 Ext. structure (for Zoom gadget) ' LPOKE newwindow%+48,newwindow%+52 ! TagList Ptr LPOKE newwindow%+52,&H8000007D ! WA_Zoom LPOKE newwindow%+56,newwindow%+68 ! Ptr to Zoom array of dimensions LPOKE newwindow%+60,0 ! TAG_DONE LPOKE newwindow%+64,0 ! DPOKE newwindow%+68,zoom_x% ! Zoomed x-coord DPOKE newwindow%+70,zoom_y% ! Zoomed y-coord DPOKE newwindow%+72,207 ! Zoomed width DPOKE newwindow%+74,scrbarheight% ! Zoomed height ' ' Open the window and store its handle ' winptr%(0)=OpenWindow(newwindow%) scrptr%(1)=0 ' IF winptr%(0)<>0 THEN ' wboffset_x%=PEEK(winptr%(0)+54) wboffset_y%=PEEK(winptr%(0)+55) ' currscreen%=0 maxcol%=(screenwidth%-32) DIV 8 ! Maximum chars on one row indentsize%=maxcol% ! Number of chars for L/R indent IF cursorx%>=maxcol% THEN ! Check that cursor within range cursorx%=maxcol%-1 ENDIF ' windowfontsize%=DPEEK(winptr%(0)+110)-DPEEK(winptr%(0)+12) bottomline%=newscreenres%-13+windowfontsize% maxrow%=bottomline% DIV 8 ' create_newsize_gadget ELSE dosprint("Cannot Allocate Enough Memory For Editor Window") ram_error!=TRUE x%=0 ENDIF ELSE window_ycoord%=MIN(MAX(window_ycoord%,0),newscreenres%-11) ' ' **** Set up a NewScreen structure ... **** ' aimee$=STRING$(70,CHR$(0)) newscreen%=V:aimee$ ' ' Define the screen's width, height ' and the depth (number of bitplanes) ' DPOKE newscreen%,0 DPOKE newscreen%+2,window_ycoord% DPOKE newscreen%+4,screenwidth% DPOKE newscreen%+6,newscreenres% DPOKE newscreen%+8,screencolours% DIV 2 ' ' Define the Detail Pen and ' Block Pen colours ' POKE newscreen%+10,2 POKE newscreen%+11,1 ' ' Define the screens resolution ' mode and type as well as ' store a pointer to its title. ' Type = CUSTOMSCREEN + NS_EXTENDED + AUTOSCROLL ' DPOKE newscreen%+12,screenmode% DPOKE newscreen%+14,15+&H1000+&H4000 LPOKE newscreen%+16,myscreenfont% LPOKE newscreen%+20,screennamebuffer% ' ' Do the WorkBench 2.0 Ext. structure ' LPOKE newscreen%+32,newscreen%+36 ! TagList Ptr LPOKE newscreen%+36,&H8000003A ! SA_Pens LPOKE newscreen%+40,newscreen%+60 ! Ptr to Pens array LPOKE newscreen%+44,&H8000002F ! SA_PubName LPOKE newscreen%+48,pubscreenname% ! Ptr Public Screen Name LPOKE newscreen%+60,&HFFFFFFFF ! use default pens ' ' Open the screen and store its handle ' scrptr%(1)=OpenScreen(newscreen%) ' ' **** Set up a NewWindow structure ... **** ' aimee$=STRING$(48,CHR$(0)) newwindow%=V:aimee$ ' ' Define the x,y position of the ' window and its width & height ' DPOKE newwindow%,0 DPOKE newwindow%+2,11+pixel_offset% DPOKE newwindow%+4,screenwidth% DPOKE newwindow%+6,bottomline%+11 ' ' Define the Detail Pen and ' Block Pen colours ' POKE newwindow%+8,2 POKE newwindow%+9,1 ' ' Define the IDCMP flags to react ' to, and the display flags, and ' store a pointer to the title. ' ' Custom Editor Window IDCMP Flags = ' ' MOUSEBUTTONS + RAWKEY + MENUPICK + INTUITICKS + INACTIVEWINDOW ' LPOKE newwindow%+10,&H508+&H400000+&H80000 LPOKE newwindow%+14,&H1900 LPOKE newwindow%+26,0 ' ' State the screen to display the ' window on. 0=use WorkBench screen. ' The Type field is set to CUSTOMSCREEN ' or WBENCHSCREEN accordingly ' DPOKE newwindow%+46,15 LPOKE newwindow%+30,scrptr%(1) ' ' Open the window and store its handle ' IF scrptr%(1)<>0 THEN winptr%(0)=OpenWindow(newwindow%) IF winptr%(0)=0 THEN ~CloseScreen(scrptr%(1)) scrptr%(1)=0 ENDIF ELSE winptr%(0)=0 ENDIF ' IF winptr%(0)<>0 THEN ' wboffset_x%=0 wboffset_y%=0 ' ~ShowTitle(scrptr%(1),FALSE) currscreen%=1 maxcol%=(screenwidth%-24) DIV 8 ! Maximum chars on one row indentsize%=maxcol% ! Number of chars for L/R indent ' ELSE dosprint("Cannot Open New Screen, Reverting To Lowest Resolution ...") ram_error!=TRUE x%=1 ENDIF ENDIF ' IF NOT ram_error! THEN RASTPORT {winptr%(0)+50} rastport%={winptr%(0)+50} window_ycoord%=0 currwindow%=0 set_font(0) message("") IF noofchars%=1 AND commandtail$="" THEN ! A dummy cursor cursor_on ENDIF draw_status_bar init_prop set_colours update_tab update_line update_column update_docno update_mode update_case_flag refresh_split_pos ! Update split screen (if nec.) draw_split_bar refresh_other_split get_curpos ' ************* REDIRECT DOS SYSTEM CALLS TO THE NEW SCREEN *************** taskaddr%=FindTask(0) IF taskaddr%<>0 THEN defaultwin%=LPEEK(taskaddr%+184) LPOKE (taskaddr%+184),-1 ENDIF ' ********************* SET UP INITIAL SCREEN FORMAT ********************** attach_menus ' *********************** CREATE APPWINDOW STRUCTURE ********************** appwindow%=0 IF appwindowport%<>0 AND workbenchbase%<>0 THEN clear_registers reg%(0)=1 ! D0=ID reg%(1)=1 ! D1=UserData reg%(8)=winptr%(0) ! A0=Window reg%(9)=appwindowport% ! A1=Message Port reg%(10)=0 ! A2=Tag List reg%(14)=workbenchbase% ! A6=WorkBenchBase RCALL workbenchbase%-48,reg%() appwindow%=reg%(0) ENDIF ' *************************** MAKE SCREEN PUBLIC ************************** IF workbench_2.0! AND scrptr%(1)<>0 THEN clear_registers reg%(0)=2 reg%(8)=scrptr%(1) reg%(14)=_IntBase RCALL _IntBase-&H228,reg%() ENDIF ELSE ' ' If there was a memory error involved in opening the window/screen ... ' IF x%<>0 THEN screenres%=200 screencolours%=4 use_wbench!=TRUE open_screen ELSE buggeroff!=TRUE ENDIF ENDIF RETURN > PROCEDURE close_screen ' ' Closes the editor window/screen ' IF winptr%(0)<>0 THEN ' IF winptr%(0)<>0 AND taskaddr%<>0 THEN LPOKE (taskaddr%+184),defaultwin% ! Redirect DOS back to WBench ENDIF ' IF appwindow%<>0 AND workbenchbase%<>0 THEN ! Close AppWindow support clear_registers reg%(8)=appwindow% reg%(14)=workbenchbase% RCALL workbenchbase%-54,reg%() ENDIF ' ~ClearMenuStrip(winptr%(0)) ~CloseWindow(winptr%(0)) ENDIF ' IF scrptr%(1)<>0 THEN IF workbench_2.0! THEN REPEAT status%=CloseScreen(scrptr%(1)) IF status%=0 THEN ~Delay(20) ENDIF UNTIL status%<>0 ELSE ~CloseScreen(scrptr%(1)) ENDIF ENDIF ' winptr%(0)=0 scrptr%(0)=0 ' RETURN > PROCEDURE draw_status_bar ' ' Draws the status bar at the bottom of the screen and sets up the ranges ' for the status bar gadgets so that they can be clicked over. ' colour2(0,col1%,col0%) line(0,0,bottomline%+1,screenwidth%,bottomline%+1) IF screencolours%>2 THEN colour1(0,col3%) ELSE colour1(0,col1%) ENDIF text(0,0,bottomline%+9,"Line: 1 Column: 1 Tab: 8") IF screenwidth%>352 THEN text(0,285,bottomline%+9,"Doc:") IF screenwidth%>555 THEN text(0,484,bottomline%+9,"` '") update_time ENDIF ENDIF ' statusgadget%(0,0)=0 ! Line statusgadget%(0,1)=11*8 ' statusgadget%(1,0)=12*8-4 ! Column statusgadget%(1,1)=25*8 ' statusgadget%(2,0)=26*8-4 ! Tab statusgadget%(2,1)=34*8 ' statusgadget%(3,0)=44*8-2 ! Mode statusgadget%(3,1)=49*8-10 ' statusgadget%(4,0)=51*8-4-9 ! Time statusgadget%(4,1)=59*8+4-9 ' statusgadget%(5,0)=62*8-2-12 ! Curr Char statusgadget%(5,1)=67*8+2-12 ' statusgadget%(6,0)=69*8-6-15 ! NumL statusgadget%(6,1)=73*8+4-15 ' statusgadget%(7,0)=75*8-4-18 ! Cas statusgadget%(7,1)=78*8+6-18 ' statusgadget%(8,0)=35*8-1 ! Cur Doc No. statusgadget%(8,1)=43*8-7 RETURN > PROCEDURE do_you_really_wanna_quit(VAR buggeroff!) ' ' if either document has been updated, then the user is given the ' opportunity to save it or to quit anyway or, by clicking over the ' close gadget, to abort the quit operation and stay in EdWord. ' the parameter BUGGEROFF! will be TRUE unless the close gadget was clicked. ' ' this routine is only performed if the value of BUGGEROFF! is TRUE to ' start with - i.e. the user has selected Quit from the menu. ' IF buggeroff! THEN backup_curr_doc FOR jody%=0 TO noofdocs%-1 IF buggeroff! THEN IF (docupdated!(jody%) OR lineupdated!(jody%)) THEN ' IF curr_docno%=jody% THEN refresh!=FALSE ELSE refresh!=TRUE activate_doc(jody%) ENDIF ' IF split_screen! THEN toggle_split_screen ELSE IF refresh! refresh_multidocs ENDIF confirm_quit(buggeroff!) ' ENDIF ENDIF NEXT jody% ENDIF RETURN > PROCEDURE confirm_quit(VAR buggeroff!) ' ' The actual requester that asks you if you want to quit or not. ' updates the value of BUGGEROFF! accordingly. ' LOCAL tempfile$,curfile$ ' IF (docupdated! OR lineupdated!) THEN IF curfilename$<>"" THEN split_filename(curfilename$,dummy$,curfile$) curfile$=CHR$(34)+curfile$+CHR$(34) ELSE curfile$="Current File" ENDIF request(curfile$+" Has Not Been Saved.|Are You Sure That You Want To Quit?","QUIT EDITOR","CANCEL QUIT",x%) IF x%=0 THEN buggeroff!=FALSE ELSE buggeroff!=TRUE ENDIF ENDIF RETURN > PROCEDURE iconify ' ' This facility will iconify the EdWord editor to an App Icon on the ' WorkBench screen. Double clicking on it will resume normal operation. ' appokay!=FALSE INLINE defaultappicon%,389 ' window_test!=TRUE FOR loop%=1 TO 4 IF winptr%(loop%)<>0 THEN window_test!=FALSE ENDIF NEXT loop% ' IF workbenchbase%<>0 AND window_test! THEN iconname$="icon.library"+CHR$(0) iconbase%=OpenLibrary(V:iconname$,37) IF iconbase%<>0 THEN ' ' Try to load the appicon file from ENV: (using GetDiskObject()) ' IF env_mounted! THEN a$="ENV:EdWord/EdWordAppIcon"+CHR$(0) reg%(8)=V:a$ reg%(14)=iconbase% RCALL iconbase%-&H4E,reg%() dobj%=reg%(0) ENDIF ' ' Setup the default AppIcon DiskObject structure ' IF dobj%<>0 THEN icon_loaded!=TRUE ELSE icon_loaded!=FALSE a$=STRING$(80,CHR$(0)) dobj%=V:a$ LPOKE defaultappicon%+10,defaultappicon%+20 DPOKE dobj%,&HE310 ! do_Magic = WB_DISKMAGIC DPOKE dobj%+2,1 ! do_Version = WB_DISKVERSION DPOKE dobj%+8,0 ! do_Gadget.x = 0 DPOKE dobj%+10,0 ! do_Gadget.y = 0 DPOKE dobj%+12,54 ! do_Gadget.w = 54 DPOKE dobj%+14,23 ! do_Gadget.h = 23 LPOKE dobj%+22,defaultappicon% ! do_Gadget.Image = myappicon LPOKE dobj%+74,4000 ! do_StackSize = 4000 ENDIF DPOKE dobj%+16,5 ! do_Gadget.Flags = GADGHIMAGE|GADGHBOX DPOKE dobj%+18,3 ! do_Gadget.Activation = RELVERIFY DPOKE dobj%+20,1 ! do_Gadget.Type = BOOLGADGET LPOKE dobj%+58,&H80000000 ! do_CurrentX = NO_ICON_POSITION LPOKE dobj%+62,&H80000000 ! do_CurrentY = NO_ICON_POSITION POKE dobj%+48,0 ! dobj^.do_Type=NIL; ' ' Call, CreateMsgPort() = Exec V37 only ' execbase%=LPEEK(4) reg%(0)=0 reg%(14)=execbase% RCALL execbase%-&H29A,reg%() myport%=reg%(0) IF myport%<>0 THEN ' ' Call, AddAppIcon(0,0,"EdWord",myport,NIL,dobj,NIL) ' appiconname$="EdWord"+CHR$(0) clear_registers reg%(8)=V:appiconname$ reg%(9)=myport% reg%(11)=dobj% reg%(14)=workbenchbase% RCALL workbenchbase%-&H3C,reg%() appicon%=reg%(0) IF appicon%<>0 THEN ' ' Okay, lets go to sleep now then... (remember size of window) ' appokay!=TRUE custom_size!=TRUE custom_size%=bottomline%+24 IF use_wbench! THEN window_xcoord%=DPEEK(winptr%(0)+4) window_ycoord%=DPEEK(winptr%(0)+6) ELSE window_xcoord%=DPEEK(scrptr%(1)+8) window_ycoord%=DPEEK(scrptr%(1)+10) ENDIF close_screen ~WaitPort(myport%) ' ' And then we wake up again! ' msg%=GetMsg(myport%) ~ReplyMsg(msg%) ' ' Call, RemoveAppIcon(appicon) ' clear_registers reg%(8)=appicon% reg%(14)=workbenchbase% RCALL workbenchbase%-&H42,reg%() ' open_screen refresh_page ENDIF ' REPEAT msg%=GetMsg(myport%) IF msg%<>0 THEN ~ReplyMsg(msg%) ENDIF UNTIL msg%=0 ' ' Call, DeleteMsgPort(myport) ' reg%(8)=myport% reg%(14)=execbase% RCALL execbase%-&H2A0,reg%() ENDIF IF icon_loaded! THEN ~FreeDiskObject(dobj%) ENDIF ~CloseLibrary(iconbase%) ENDIF ENDIF ' IF NOT window_test! THEN inform("Cannot Iconify EdWord!|All Windows Must|Be Closed First.") ELSE IF NOT appokay! inform("Could Not Create App|Icon To Iconify EdWord") ENDIF RETURN ' ******************** INITIALISE CHECKS MADE ON START UP ******************* > PROCEDURE check_for_ntsc ' ' This routine checks to see if the machine that EdWord is being run ' on is an NTSC or a PAL machine. The flag NTSCAMIGA! is updated accordingly ' IF (DPEEK(_GfxBase+206) AND 1)<>0 THEN ntscamiga!=TRUE ELSE ntscamiga!=FALSE ENDIF ' ilock%=LockIBase(0) activescreen%={_IntBase+60} ! FirstScreen address in Screen list ~UnlockIBase(ilock%) wbench_size%=DPEEK(activescreen%+14) wbench_interlace!=(DPEEK(activescreen%+20) AND &H8000)<>0 ' RETURN > PROCEDURE check_for_virus ' ' This procedure effectively checks for a (possible) virus in memory. ' What it does is looks at a number of vectors in the execbase structure. ' All of these vectors should be zero - but if one of them is not, then ' there is some RAM resident program lurking around, which in the most ' cases will be some kind of virus. You are given the option to clear ' the vector (back to 0) if the user desires this. N.B. Only RAM is tested. ' No bootblocks are examined or files. See the end of the procedure for a ' list of all the vectors which are checked. ' LOCAL offset%,cancel! ' IF NOT disablevcheck! THEN cancel!=FALSE RESTORE execvectors execbase%={4} ! ExecBase address FOR vcheck%=0 TO 20 READ vector$,offset% ! Get next vector to check EXIT IF vector$="*" OR cancel! IF LPEEK(execbase%+offset%)<>0 AND LPEEK(execbase%+offset%)<>&HFFFFFFFF request("POSSIBLE VIRUS ALERT ! : "+vector$+" = $"+HEX$(LPEEK(execbase%+offset%),8),"CLEAR VECTOR","IGNORE IT",x%) IF x%=0 THEN request("ATTENTION : I Suggest You Get Out|Your Virus Exterminators NOW!","YOU BET YOUR ASS!","",x%) cancel!=TRUE ELSE LPOKE (execbase%+offset%),0 ! Clear the vector request("OKAY : "+vector$+" Has Been Reset To $00000000","THANKS EDDY!","",x%) ENDIF ENDIF NEXT vcheck% ENDIF ' execvectors: DATA WarmCapture,50 DATA CoolCapture,46 DATA ColdCapture,42 DATA KickMemPtr,546 DATA KickTagPtr,550 DATA KickCheckSum,554 DATA *,0 RETURN > PROCEDURE check_for_workbench2.0 ' ' This procedure checks to see what version of the operating system ' the current machine is running under. A boolean flag WORKBENCH_2.0! ' is updated to this effect. (i.e. true if version 36 or greater). ' LOCAL name$,offset% ' workbench_2.0!=FALSE name$="intuition.library"+CHR$(0) offset%=OpenLibrary(V:name$,37) IF offset%<>0 THEN ~CloseLibrary(offset%) workbench_2.0!=TRUE ENDIF RETURN > PROCEDURE check_todays_date ' MODE 0 a$=LEFT$(DATE$,6) IF a$="25.09." THEN inform("It's The 25th Of September, so ...|Happy Birthday To You, Happy Birthday To You|Happy Birthday Dear Martin, Happy Birthday To You!!") ELSE IF a$="25.12." inform("!!! It's Christmas Day !!!|Hope You Have A Totally Sexy Christmas!|Lots of love & kisses, EdWord.") ELSE IF a$="01.01." inform("!!! It's New Years Day !!!|Hope You Have A Michelle-Pfeiffer-full Year!|Best Wishes For The Coming (ooh-er) Year, EdWord.") ENDIF ' IF force_ntsc! OR ntscamiga! THEN MODE 1 ! Use the American format for dates ELSE MODE 0 ! Use the British format for dates ENDIF RETURN > PROCEDURE check_for_pubscreen ' ' ' IF workbench_2.0! THEN IF userpubname! AND (LEN(userpubname$)>0) THEN defpubname$=userpubname$ ELSE defpubname$="EdWordScreen" ENDIF pubname$=defpubname$ count%=1 REPEAT ' pubname$=pubname$+CHR$(0) reg%(8)=V:pubname$ reg%(14)=_IntBase RCALL _IntBase-&H1FE,reg%() ' IF reg%(0)<>0 THEN reg%(8)=V:pubname$ reg%(9)=reg%(0) reg%(14)=_IntBase RCALL _IntBase-&H204,reg%() ' count%=count%+1 pubname$=defpubname$+STR$(count%) reg%(0)=0 ENDIF ' UNTIL reg%(0)=0 ' BMOVE V:pubname$,pubscreenname%,LEN(pubname$) ' ENDIF RETURN > PROCEDURE assign(VAR devlist$) ' ' This procedure will search the list of devices which are currently ' recognised (as output by the Assign command from the CLI). My God !!! ' What a bloody auful task it was to get this little bugger working !! ' I spent no less than 16 hours trying to work out where the hell the ' Amiga stores it's list of devices. (I even dissassembled the entire ' code for the Assign command - fat lot of good that did!). Well here's ' how it is done (refer to `libraries/dosextens.i' for full structures) ' First of all you get a hold of the dosbase address, from there you ' find a pointer to a structure called RootNode which in turn contains ' a BCPL pointer to a structure called DosInfo. By the way, as I eventually ' discovered (!?*@), a BCPL pointer must be longword aligned and consists ' of the LONGWORD address of the actual address - i.e. you have to multiply ' the devious cad by four to get the actual memory address. Anyway, within ' the DosInfo structure, there is a pointer to a DevList structre - at last! ' from there, there are a number of things in the structure. The first ' address contains a (BCPL) link to the next device in the list (or a zero ' if end of list). There is also a BCPL pointer to a BCPL string which is ' in the length-first format (it also seems to be zero terminated in the ' cases that I have looked at, but I don't know for definate). So now you ' just keep going along the list until you get to the end. You also have ' a longword in the list which details the type of device the current one ' is. This can be either 0 (a device), 1 (a directory) or 2 (a volume). ' ' This procedure will return a string, DEVLIST$, containing all the devices ' that exist separated by a colon ":". ' ' Well, that was easy !!@$! Oh why do I do this to myself ? Anyway, it's ' now 1:45am so I'm buggering off to my kip .... Martin Reddy 4/9/91 / ' LOCAL length%,device$ ' devlist$="" devtype$="" rootnode%={_DosBase+&H22} ! Get address for RootNode from dosbase dosinfo%={rootnode%+&H18}*4 ! Get BPTR address for DosInfo struct devlist%={dosinfo%+&H4}*4 ! Get BPTR address for DevList struct WHILE devlist%<>0 ! While still devices to examine devname%={devlist%+&H28}*4 ! Get BSTR address for the device devtype%={devlist%+4} ! 0=Device; 1=Directory; 2=Volume length%=PEEK(devname%) ! Get length of device string device$=SPACE$(length%) ! Allocate some memory for the string BMOVE devname%+1,V:device$,length% ! Copy the device string text to DEVICE$ devlist$=devlist$+device$+":" ! Add device to device list (+ colon) devtype$=devtype$+STR$(devtype%)+SPACE$(length%) devlist%={devlist%}*4 ! Move BPTR address onto next device WEND RETURN ' ****************** MULTIPLE DOCUMENT HANDLING ROUTINES ******************** > PROCEDURE install_multidocs ' ' This procedure sets up the storage for the settings for two lots of ' of the variables used to describe a documents state. This is done ' by having arrays with two elements. This allows me to store the current ' status of 2 documents in memory at once. ' LOCAL m% ' max_docs%=15 ' m%=max_docs%-1 DIM docstart%(m%),lineadd%(m%),curradd%(m%),topadd%(m%),false_eof!(m%) DIM memorysize%(m%),curline%(m%),nooflines%(m%),indent%(m%),noofchars%(m%) DIM lineupdated!(m%),docupdated!(m%),lineoverflow!(m%),blockon!(m%) DIM blockstart%(m%),blockend%(m%),vertstart%(m%),vertend%(m%),vertblock!(m%) DIM vertstartline%(m%),vertendline%(m%),vertx1%(m%),vertx2%(m%) DIM cursorx%(m%),cursory%(m%),curfilename$(m%),mark0%(m%),mark1%(m%),mark2%(m%) DIM markt0%(m%),markt1%(m%),markt2%(m%),markx0%(m%),markx1%(m%),markx2%(m%) ' curr_docno%=0 noofdocs%=1 FOR m%=1 TO max_docs%-1 docstart%(m%)=0 NEXT m% ' RETURN > PROCEDURE refresh_multidocs ' ' Refreshes the screen ' IF NOT split_screen! THEN clear_screen ENDIF update_line update_column update_docno update_prop message("") refresh_page RETURN > PROCEDURE tell_docno ' ' Displays a message on the screen title stating the current document no. ' IF NOT buggeroff! THEN alert("Document "+STR$(curr_docno%+1)+" of "+STR$(noofdocs%)) ENDIF RETURN > PROCEDURE backup_curr_doc ' ' backs up the current documents settings into memory so that they can ' be retrieved at a later point. ' docstart%(curr_docno%)=docstart% lineadd%(curr_docno%)=lineadd% curradd%(curr_docno%)=curradd% topadd%(curr_docno%)=topadd% false_eof!(curr_docno%)=false_eof! memorysize%(curr_docno%)=memorysize% curline%(curr_docno%)=curline% nooflines%(curr_docno%)=nooflines% indent%(curr_docno%)=indent% noofchars%(curr_docno%)=noofchars% lineupdated!(curr_docno%)=lineupdated! docupdated!(curr_docno%)=docupdated! lineoverflow!(curr_docno%)=lineoverflow! cursorx%(curr_docno%)=cursorx% cursory%(curr_docno%)=cursory% curfilename$(curr_docno%)=curfilename$ blockon!(curr_docno%)=blockon! vertblock!(curr_docno%)=vertblock! blockstart%(curr_docno%)=blockstart% blockend%(curr_docno%)=blockend% vertstart%(curr_docno%)=vertstart% vertend%(curr_docno%)=vertend% vertstartline%(curr_docno%)=vertstartline% vertendline%(curr_docno%)=vertendline% vertx1%(curr_docno%)=vertx1% vertx2%(curr_docno%)=vertx2% mark0%(curr_docno%)=mark%(0,0) mark1%(curr_docno%)=mark%(1,0) mark2%(curr_docno%)=mark%(2,0) markt0%(curr_docno%)=mark%(0,1) markt1%(curr_docno%)=mark%(1,1) markt2%(curr_docno%)=mark%(2,1) markx0%(curr_docno%)=mark%(0,2) markx1%(curr_docno%)=mark%(1,2) markx2%(curr_docno%)=mark%(2,2) RETURN > PROCEDURE activate_doc(new_doc%) ' ' IF curr_docno%<>new_doc% THEN curr_docno%=new_doc% ' IF split_screen! THEN split%(activesplit%)=curr_docno% ENDIF ' docstart%=docstart%(curr_docno%) lineadd%=lineadd%(curr_docno%) curradd%=curradd%(curr_docno%) topadd%=topadd%(curr_docno%) false_eof!=false_eof!(curr_docno%) memorysize%=memorysize%(curr_docno%) curline%=curline%(curr_docno%) nooflines%=nooflines%(curr_docno%) indent%=indent%(curr_docno%) noofchars%=noofchars%(curr_docno%) lineupdated!=lineupdated!(curr_docno%) docupdated!=docupdated!(curr_docno%) lineoverflow!=lineoverflow!(curr_docno%) cursorx%=cursorx%(curr_docno%) cursory%=cursory%(curr_docno%) curfilename$=curfilename$(curr_docno%) blockon!=blockon!(curr_docno%) vertblock!=vertblock!(curr_docno%) blockstart%=blockstart%(curr_docno%) blockend%=blockend%(curr_docno%) vertstart%=vertstart%(curr_docno%) vertend%=vertend%(curr_docno%) vertstartline%=vertstartline%(curr_docno%) vertendline%=vertendline%(curr_docno%) vertx1%=vertx1%(curr_docno%) vertx2%=vertx2%(curr_docno%) mark%(0,0)=mark0%(curr_docno%) mark%(1,0)=mark1%(curr_docno%) mark%(2,0)=mark2%(curr_docno%) mark%(0,1)=markt0%(curr_docno%) mark%(1,1)=markt1%(curr_docno%) mark%(2,1)=markt2%(curr_docno%) mark%(0,2)=markx0%(curr_docno%) mark%(1,2)=markx1%(curr_docno%) mark%(2,2)=markx2%(curr_docno%) ENDIF RETURN > PROCEDURE allocate_new_doc(VAR error!) ' ' Allocates space for a new document and resets all of its parameters ' it also increments the count of documents ' error!=TRUE IF noofdocs%=max_docs% THEN inform("Cannot Create A New Document!|Maximum of "+STR$(max_docs%)+" Documents Allowed.") ELSE next_docno%=noofdocs% docstart%(next_docno%)=AllocMem(memorysize%,1) IF docstart%(next_docno%)=0 THEN inform("Unable To Create New Document!|Not Enough Memory.") ELSE error!=FALSE noofdocs%=noofdocs%+1 ' backup_curr_doc lineadd%(next_docno%)=docstart%(next_docno%) curradd%(next_docno%)=docstart%(next_docno%) topadd%(next_docno%)=docstart%(next_docno%) false_eof!(next_docno%)=FALSE memorysize%(next_docno%)=memorysize% curline%(next_docno%)=1 nooflines%(next_docno%)=1 indent%(next_docno%)=0 noofchars%(next_docno%)=1 lineupdated!(next_docno%)=FALSE docupdated!(next_docno%)=FALSE lineoverflow!(next_docno%)=FALSE cursorx%(next_docno%)=0 cursory%(next_docno%)=0 curfilename$(next_docno%)="" blockon!(next_docno%)=FALSE vertblock!(next_docno%)=FALSE blockstart%(next_docno%)=0 blockend%(next_docno%)=0 vertstart%(next_docno%)=0 vertend%(next_docno%)=0 vertstartline%(next_docno%)=0 vertendline%(next_docno%)=0 vertx1%(next_docno%)=0 vertx2%(next_docno%)=0 mark0%(next_docno%)=0 mark1%(next_docno%)=0 mark2%(next_docno%)=0 markt0%(next_docno%)=0 markt1%(next_docno%)=0 markt2%(next_docno%)=0 markx0%(next_docno%)=0 markx1%(next_docno%)=0 markx2%(next_docno%)=0 POKE docstart%(next_docno%),lf% ENDIF ENDIF RETURN > PROCEDURE create_doc ' ' Creates a new document and activates it as the current one ' free_abyss cursor_off allocate_new_doc(error!) IF NOT error! THEN activate_doc(noofdocs%-1) refresh_multidocs tell_docno ENDIF RETURN > PROCEDURE remove_doc ' ' Removes the current document from memory and restores its memory ' IF noofdocs%>1 THEN doit!=TRUE IF (lineupdated! OR docupdated!) THEN request("Current File Has Been Updated!|Please Confirm Removal Of This Document","REMOVE","CANCEL",x%) doit!=(x%<>0) ENDIF ' IF doit! THEN ' ' Free the memory for the current document ' free_abyss cursor_off backup_curr_doc ~FreeMem(docstart%(curr_docno%),memorysize%(curr_docno%)) ' ' shuffle all other document's information down by one array element ' delete_doc%=curr_docno% FOR jody%=delete_doc%+1 TO noofdocs%-1 activate_doc(jody%) curr_docno%=curr_docno%-1 backup_curr_doc NEXT jody% noofdocs%=noofdocs%-1 docstart%(noofdocs%)=0 activate_doc(MIN(delete_doc%,noofdocs%-1)) ' ' And refresh everything ' othersplit%=(activesplit% MOD 2)+1 IF split_screen! THEN IF split%(othersplit%)=delete_doc% split%(othersplit%)=MIN(split%(othersplit%),noofdocs%-1) refresh_other_split ELSE IF split%(othersplit%)>delete_doc% split%(othersplit%)=MAX(split%(othersplit%)-1,0) ENDIF ENDIF refresh_multidocs tell_docno ENDIF ENDIF RETURN > PROCEDURE next_doc ' ' Moves onto the next document in memory ' LOCAL error! ' IF noofdocs%>1 THEN free_abyss backup_curr_doc newdoc%=(curr_docno%+1) MOD noofdocs% activate_doc(newdoc%) IF NOT error! THEN refresh_multidocs tell_docno ENDIF ENDIF RETURN > PROCEDURE prev_doc ' ' Moves onto the previous document in memory ' LOCAL error! ' IF noofdocs%>1 THEN free_abyss backup_curr_doc newdoc%=(curr_docno%+noofdocs%-1) MOD noofdocs% activate_doc(newdoc%) IF NOT error! THEN refresh_multidocs tell_docno ENDIF ENDIF RETURN > PROCEDURE select_doc ' ' This is the routine which toggles the current document in memory. i.e. ' If document 1 is in current use, then document 2 will be swithed in and ' vice-versa. ' LOCAL loop% ' IF noofdocs%=1 THEN request("Cannot Select An Alternative Document!|You Currently Only Have The One","CREATE DOC","CANCEL",x%) IF x%<>0 THEN create_doc ENDIF ELSE backup_curr_doc winh%=noofdocs%*9+59 winw%=300 open_window(2,0,0,winw%,winh%,"Select Document") IF NOT unable_to_open_window! THEN draw_reverse_box(2,30,20,winw%-30,21+noofdocs%*9) colour1(2,0) pbox(2,32,21,winw%-32,20+noofdocs%*9) create_gadget(2,30,winh%-27,"~SELECT",gad3%()) create_gadget(2,winw%-96,winh%-27,"~"+cancel$,gad1%()) colour2(2,pen1%,0) FOR loop%=0 TO noofdocs%-1 aimee$=curfilename$(loop%) IF aimee$="" THEN aimee$="Untitled" ELSE split_filename(aimee$,dummy$,file$) aimee$=file$ ENDIF aimee$=STR$(loop%+1)+". "+aimee$ text(2,37,28+loop%*9,LEFT$(aimee$,28)) NEXT loop% colour2(2,pen1%,backcol%) text(2,18,28+curr_docno%*9,CHR$(187)) ' okay!=FALSE cancel!=FALSE newdoc%=curr_docno% REPEAT test_for_sleep(2) test_gadget(2,gad1%(),cancel!) test_gadget(2,gad3%(),okay!) ' IF mouse! AND (event_y%>=20) AND (event_y%<=21+noofdocs%*9) THEN gad2%(0)=32 gad2%(1)=21+9*((event_y%-20) DIV 9) gad2%(2)=winw%-32 gad2%(3)=gad2%(1)+8 temp_gadgets!=alt_gadgets! alt_gadgets!=FALSE test_gadget(2,gad2%(),okay!) alt_gadgets!=temp_gadgets! IF okay! THEN newdoc%=MIN(MAX((event_y%-20) DIV 9,0),noofdocs%-1) ENDIF ENDIF ' IF event_key$=CHR$(27) OR UPPER$(event_key$)="C" THEN cancel!=TRUE ELSE IF event_key$=CHR$(13) OR UPPER$(event_key$)="S" okay!=TRUE ELSE IF event_key$=uparrow$ AND newdoc%>0 colour2(2,backcol%,backcol%) text(2,18,28+newdoc%*9,CHR$(187)) newdoc%=newdoc%-1 colour1(2,pen1%) text(2,18,28+newdoc%*9,CHR$(187)) ELSE IF event_key$=dnarrow$ AND newdoc%0 AND VAL(event_key$)<=noofdocs% okay!=TRUE newdoc%=VAL(event_key$)-1 gad2%(0)=32 gad2%(1)=21+9*newdoc% gad2%(2)=winw%-32 gad2%(3)=gad2%(1)+8 test_gadget_keypress(2,gad2%(),okay!) ENDIF UNTIL cancel! OR okay! OR abortgadget! test_gadget_keypress(2,gad1%(),cancel!) test_gadget_keypress(2,gad3%(),okay!) close_window(2) ' IF okay! AND (newdoc%<>curr_docno%) AND (newdoc%>=0) AND (newdoc%<=noofdocs%-1) THEN free_abyss activate_doc(newdoc%) refresh_multidocs tell_docno ENDIF ENDIF ENDIF ' RETURN ' ********************* SPLIT SCREEN OPERATION ROUTINES ********************* > PROCEDURE toggle_split_screen ' ' Toggles the screen format between a split screen or full sized. this ' option is called by the Project menu option. If there is not enough ' memory for a second document, then the operation will fail and an ' appropriate message will be displayed. ' cursor_off free_abyss split_screen!=NOT split_screen! IF split_screen! THEN ' error!=FALSE IF noofdocs%=1 THEN allocate_new_doc(error!) ENDIF ' IF NOT error! THEN menu_text(6,14,"Full Screen") ' ' Refresh other side of the split screen ' calculate_split_screen draw_split_bar activate_split(activesplit%) refresh_page refresh_other_split update_prop ELSE split_screen!=FALSE ENDIF ' ELSE ' ' If split screen is off, then just do a screen refresh and all ' should be back to usual ' menu_text(6,14,"Split Screen") maxrow%=bottomline% DIV 8 text_offset%=0 colour1(0,0) pbox(0,maxcol%*8,0,screenwidth%-25+(use_wbench!*8),bottomline%-2) refresh_multidocs ENDIF RETURN > PROCEDURE refresh_split_pos ' ' updates the parameters for a split screen. This includes ' the size of each screen and which documents appear within each by default ' ' Calculate how many lines of text will be used by each side of the ' split screen. ' IF split_screen! THEN maxrow%(1)=maxrow% DIV 2 maxrow%(2)=maxrow%-maxrow%(1)-1 ' ' Calculate position of dividing line between the two documents ' split_line%=maxrow%(1)*8+1 text_offset%(1)=0 text_offset%(2)=(maxrow%(1)+1)*8 ' maxrow%=maxrow%(activesplit%) text_offset%=text_offset%(activesplit%) ENDIF RETURN > PROCEDURE calculate_split_screen ' ' updates the parameters for a split screen. This includes ' the size of each screen and which documents appear within each by default ' ' Calculate how many lines of text will be used by each side of the ' split screen. ' IF split_screen! THEN ' refresh_split_pos ' ' Decided which 2 documents are to be displayed ' split%(1)=curr_docno% split%(2)=(curr_docno%+1) MOD noofdocs% ' ' Specify the active split ' activesplit%=1 maxrow%=maxrow%(activesplit%) text_offset%=text_offset%(activesplit%) ENDIF RETURN > PROCEDURE draw_split_bar ' ' Draws a dividing line between two documents for the split screen facility ' starting at y-coordinate Y. ' LOCAL x%,y% ' IF split_screen! THEN x%=screenwidth%-25+(use_wbench!*8) y%=split_line% colour1(0,0) pbox(0,0,y%-1,x%,y%+6) colour1(0,3) line(0,0,y%+1,x%,y%+1) line(0,0,y%+4,x%,y%+4) pattern_box(0,0,y%+2,x%,y%+3) ENDIF RETURN > PROCEDURE activate_split(splitno%) ' ' calculates the values for MAXROW and TEXT_OFFSET which should be used ' for the current split/full screen combination. ' IF split_screen! THEN ' activesplit%=splitno% backup_curr_doc maxrow%=maxrow%(activesplit%) text_offset%=text_offset%(activesplit%) activate_doc(split%(activesplit%)) check_split_range ' ENDIF RETURN > PROCEDURE refresh_other_split ' ' Refreshes the screen in the other side of the split screen from the ' currently active one. ' IF split_screen! THEN free_abyss ' activate_split((activesplit% MOD 2)+1) refresh_page_nocursor activate_split((activesplit% MOD 2)+1) ' ENDIF RETURN > PROCEDURE switch_to_other_split ' ' Switches control to the other side of the split ' IF split_screen! THEN free_abyss cursor_off activate_split((activesplit% MOD 2)+1) refresh_multidocs ENDIF RETURN > PROCEDURE check_split_range ' ' Checks to make sure that the cursor is still visible on the screen ' when a split screen view is enabled. This is necessary because only ' one half of the screen is visible at any time and so the cursor may ' be on the other half. ' WHILE cursory%>=maxrow% AND cursory%>0 next_line(topadd%) cursory%=cursory%-1 WEND RETURN > PROCEDURE drag_split_bar ' ' This facility lets the user move the position of the split bar which ' divides the screen when using a split screen view. i.e. you can change ' the proportions of visible sections of the two documents. ' LOCAL y%,x%,lim1%,lim2% ' x%=screenwidth%-25+(use_wbench!*8) lim1%=4*8 lim2%=bottomline%-4*8 ' IF mouse! AND split_screen! THEN ' ' Let the user drag the split bar line ' cursor_off new_line%=split_line% xor_frame(0,0,new_line%-1,x%,new_line%+6) REPEAT y%=event_y% IF y%>lim1% AND y%new_line% THEN xor_frame(0,0,new_line%-1,x%,new_line%+6) new_line%=y% xor_frame(0,0,new_line%-1,x%,new_line%+6) ENDIF ENDIF test_events(0) UNTIL NOT mouse! xor_frame(0,0,new_line%-1,x%,new_line%+6) ' ' refresh the screen with the new split bar position ' IF new_line%<>split_line% THEN ' ' Calculate the new dimensions ' split_line%=new_line% maxrow%(1)=split_line% DIV 8 maxrow%(2)=(bottomline% DIV 8)-maxrow%(1)-1 text_offset%(2)=(maxrow%(1)+1)*8 maxrow%=maxrow%(activesplit%) text_offset%=text_offset%(activesplit%) ' ' Redraw the screen ' colour1(0,0) pbox(0,maxcol%*8,0,x%,bottomline%-2) draw_split_bar refresh_other_split refresh_page update_line update_prop ENDIF cursor_on ENDIF ' RETURN ' ***************** CUSTOM STRING/BOOLEAN GADGETS ROUTINES ****************** > PROCEDURE string_gadget(window%,sx%,sy%,boxsize%,maxsize%,VAR text$,move%) ' ' A procedure to mimick the intuition string gadget and also provide a ' extra facilities. The procedure exits under a number of conditions and ' sets the value of MOVE depending upon wether a mouse button is pressed (0), ' RETURN is pressed (2) or cursor up/down is pressed(-1,+1). Key functions = ' ' Cursor left and right = scroll through the string ' Shift + left & right cursor = goto start/end of text ' ESC or Amiga+X = clear current text. ' Help or Amiga+Q = undo changes ' F1 = Document Text Insertion ' LOCAL po%,edge%,oldtext$ ' ' >>>>>>>>>>>>>>> INITIALISE ALL VARIABLES & CONSTANTS <<<<<<<<<<<<<<<< ' string_border(window%,sx%,sy%,boxsize%) stillamiga!=FALSE in_gadget!=TRUE oldtext$=text$ po%=MIN(string_position%,LEN(text$)+1) edge%=1 move%=0 WHILE (po%-edge%)>=boxsize% edge%=edge%+1 WEND ' ' >>> RESET A POINTER TO THE START OF WORD WHICH DOCUMENT CURSOR IS OVER <<< ' text_pointer%=curradd% WHILE (PEEK(text_pointer%)=32 OR PEEK(text_pointer%-1)<>32) AND (PEEK(text_pointer%)=tab% OR PEEK(text_pointer%-1)<>tab%) AND text_pointer%>lineadd% text_pointer%=text_pointer%-1 WEND ' ' >>>>>>>>>>>> POSITION CURSOR UNDER MOUSE IF CLICKED <<<<<<<<<<<<<<<<<< ' IF ie_click! THEN IF event_y%>=sy%-8 AND event_y%sx% AND event_x%>>>>>>>>>>>>> REFRESH THE CURRENT STRING & CURSOR <<<<<<<<<<<<<<<<< ' colour2(window%,col1%,col0%) text(window%,sx%,sy%,MID$(text$+SPACE$(boxsize%),edge%,boxsize%)) colour2(window%,col2%,col3%) text(window%,sx%+po%*8-edge%*8,sy%,MID$(text$+" ",po%,1)) ' ' >>>>>>>>>>>>>>>>>>>>>>> WAIT FOR A KEYPRESS <<<<<<<<<<<<<<<<<<<<<<<< ' REPEAT test_for_sleep(window%) ramiga_test IF mouse! OR rmouse! event_key$="EXIT" ENDIF ignore_key_repeat(event_key$) UNTIL event_key$<>"" OR abortgadget! ' ' >>>>>> GET NEXT CHARACTER FROM DOCUMENT IF F1 IS PRESSED <<<<<<<<<<<< ' IF event_key$=f1$ AND PEEK(text_pointer%)<>lf% THEN event_key$="|"+CHR$(PEEK(text_pointer%)) text_pointer%=text_pointer%+1 ENDIF ' ' >>>>>>>>>>>>>>> WAS A VALID PRINTABLE KEY PRESSED? <<<<<<<<<<<<<<<<< ' IF ((event_key$>=" " AND event_key$CHR$(161)) AND LEN(text$)"EXIT" THEN text$=LEFT$(text$,po%-1)+thekey$+MID$(text$,po%,LEN(text$)-po%+1) po%=po%+1 IF po%>boxsize% THEN edge%=edge%+1 ENDIF ENDIF ENDIF ' ' >>>>>>>>>>>>> WAS A DELETE OR BACKSPACE KEY PRESSED? <<<<<<<<<<<<<<< ' IF (event_key$=CHR$(8) OR event_key$=CHR$(127)) OR (event_key$=ctrlk$ OR event_key$=ctrlu$) IF (NOT ie_shift!) AND event_key$<>ctrlk$ AND event_key$<>ctrlu$ THEN IF event_key$=CHR$(127) THEN IF po%>LEN(text$) THEN text$=text$+" " ENDIF po%=po%+1 ENDIF IF po%>1 THEN text$=LEFT$(text$,po%-2)+MID$(text$,po%,LEN(text$)-po%+1) po%=po%-1 ENDIF IF po%>>>>>>>>>>>>>>> WAS THE LEFT CURSOR KEY PRESSED? <<<<<<<<<<<<<<<<<< ' IF event_key$=leftarrow$ AND po%>1 THEN IF ie_alt! THEN event_key$=shiftleft$ ELSE po%=po%-1 IF po%>>>>>>>>>>>>>> WAS THE RIGHT CURSOR KEY PRESSED? <<<<<<<<<<<<<<<<<< ' IF event_key$=rightarrow$ AND po%=boxsize% THEN edge%=edge%+1 ENDIF ENDIF ENDIF ' ' >>>>>>>> IF SHIFT+LEFT CURSOR THEN GOTO START OF TEXT <<<<<<<<<<<<<< ' IF event_key$=shiftleft$ OR event_key$=ctrlt$ OR event_key$=ctrla$ THEN po%=1 edge%=1 ENDIF ' ' >>>>>>>>> IF SHIFT+RIGHT CURSOR THEN GOTO END OF TEXT <<<<<<<<<<<<<< ' IF event_key$=shiftright$ OR event_key$=ctrlb$ OR event_key$=ctrlz$ THEN po%=LEN(text$)+1 edge%=1 WHILE (po%-edge%)>=boxsize% edge%=edge%+1 WEND ENDIF ' ' >>>>>>>>>>>>>>> CLEAR THE TEXT IF ESCAPE IS PRESSED <<<<<<<<<<<<<<<< ' IF event_key$=CHR$(27) OR event_key$=ctrlx$ THEN po%=1 edge%=1 text$="" colour2(window%,col0%,col0%) text(window%,sx%,sy%,SPACE$(boxsize%)) ENDIF IF event_key$=uparrow$ THEN event_key$="EXIT" move%=-1 ENDIF IF event_key$=dnarrow$ OR event_key$=CHR$(9) THEN event_key$="EXIT" move%=1 ENDIF ' ' >>>>>>>>>>>>>>>>>> UNDO FUNCTION IF HELP PRESSED <<<<<<<<<<<<<<<<<<< ' IF event_key$=helpkey$ text$=oldtext$ po%=MIN(po%,LEN(text$)+1) edge%=1 WHILE (po%-edge%)>=boxsize% edge%=edge%+1 WEND colour2(window%,col0%,col0%) text(window%,sx%,sy%,SPACE$(boxsize%)) ENDIF UNTIL event_key$=CHR$(13) OR event_key$="EXIT" OR abortgadget! ' ' >>>>>>>>>>>>>>>>>>> SWITCH CURSOR OFF BEFORE EXITING <<<<<<<<<<<<<<<<< ' IF event_key$=CHR$(13) THEN move%=2 ENDIF ' colour2(window%,col1%,col0%) text(window%,sx%+po%*8-edge%*8,sy%,MID$(text$+" ",po%,1)) string_position%=po% in_gadget!=FALSE RETURN > PROCEDURE string_border(window%,x%,y%,boxsize%) ' ' draws a string gadget border as used the String_Gadget() and the ' Refresh_String() routines. ' IF screencolours%>2 THEN draw_reverse_box(window%,x%-5,y%-8,x%+boxsize%*8+4,y%+3) draw_box(window%,x%-7,y%-9,x%+boxsize%*8+6,y%+4) ELSE draw_box(window%,x%-5,y%-8,x%+boxsize%*8+4,y%+3) ENDIF ' ' >>>>>>>>>>>>>>>>> CLEAR THE CONTENTS OF THE GADGET <<<<<<<<<<<<<<<<<<< ' colour1(window%,col0%) box(window%,x%-3,y%-7,x%+boxsize%*8+2,y%+2) box(window%,x%-2,y%-7,x%+boxsize%*8+1,y%+2) box(window%,x%-1,y%-7,x%+boxsize%*8,y%+2) RETURN > PROCEDURE refresh_string(window%,x%,y%,boxsize%,text$) ' ' draws a string_gadget and refreshes its contents just as "string_gadget" ' would and then exits - i.e. does not accept keyboard input ' ' string_border(window%,x%,y%,boxsize%) colour2(window%,col1%,col0%) text(window%,x%,y%,LEFT$(text$+SPACE$(boxsize%),boxsize%)) RETURN > PROCEDURE create_gadget(window%,x%,y%,text$,VAR array%()) ' ' Creates a boolean gadget at the pixel co-ordinates (X,Y) which ' displays the message contained in TEXT$. The boundaries of the ' gadget are stored in the ARRAY() so that we can tell if the user ' has clicked over the gagdet ' LOCAL width%,height%,offx%,offy%,x1%,uline% ' IF NOT arexx_command! THEN ' uline%=INSTR(text$,"~") IF uline%>0 THEN text$=LEFT$(text$,uline%-1)+RIGHT$(text$,LEN(text$)-uline%) ENDIF ' offx%=0 offy%=0 IF LEFT$(text$,1)="@" THEN text$=RIGHT$(text$,LEN(text$)-1) offx%=4 offy%=3 ENDIF width%=LEN(text$)*8+16 height%=13 colour1(window%,backcol%) pbox(window%,x%+offx%+1,y%-1+offy%,width%+x%-offx%,height%+y%-offy%) draw_box(window%,x%-1+offx%,y%-2+offy%,width%+2+x%-offx%,height%+1+y%-offy%) ' text$=TRIM$(text$) x1%=(width%-LEN(text$)*8) DIV 2 ' colour2(window%,pen1%,backcol%) text(window%,x%+x1%+1,y%+9,text$) ' IF uline%>0 THEN line(window%,x%+uline%*8+1,y%+11,x%+uline%*8+8,y%+11) ENDIF ' array%(0)=x%+offx%-1 array%(1)=y%+offy%-2 array%(2)=width%+x%-offx%+2 array%(3)=height%+y%-offy%+1 ENDIF RETURN > PROCEDURE create_swirl_gadget(window%,x%,y%,text$,VAR array%()) ' ' Creates a boolean gadget at the pixel co-ordinates (X,Y) which ' displays the message contained in TEXT$. The boundaries of the ' gadget are stored in the ARRAY() so that we can tell if the user ' has clicked over the gagdet. This is a WorkBench 2.0 boolean gagdet ' with the rotation symbol at the front. ' LOCAL width%,height%,offx%,offy%,x1% offx%=0 offy%=0 IF LEFT$(text$,1)="@" THEN text$=RIGHT$(text$,LEN(text$)-1) offx%=4 offy%=3 ENDIF width%=LEN(text$)*8+32 height%=13 colour1(window%,backcol%) pbox(window%,x%+offx%,y%-1+offy%,width%+1+x%-offx%,height%+y%-offy%) draw_box(window%,x%-1+offx%,y%-2+offy%,width%+2+x%-offx%,height%+1+y%-offy%) colour1(window%,shadow2%) line(window%,x%+offx%+20,y%+offy%,x%+offx%+20,height%-1+y%-offy%) colour1(window%,shadow1%) line(window%,x%+offx%+21,y%+offy%,x%+offx%+21,height%-1+y%-offy%) ' IF offx%=0 THEN big_swirl_gadget(window%,x%+6,y%+2) ELSE wee_swirl_gadget(window%,x%+10,y%+3) ENDIF ' text$=TRIM$(text$) x1%=((width%-LEN(text$)*8) DIV 2)+12 ' colour2(window%,pen1%,backcol%) text(window%,x%+x1%,y%+9,text$) array%(0)=x%+offx%-1 array%(1)=y%+offy%-2 array%(2)=width%+x%-offx%+2 array%(3)=height%+y%-offy%+1 RETURN > PROCEDURE test_gadget(window%,VAR array%(),found!) ' ' Tests to see if a mouse click was over a gadget. If so, then ' the gadget is inverted for the duration of the click and the ' boolean flag FOUND! is set to true. This mimicks the operation ' of the AmigaDOS boolean gagdet quite admirably - even if I do ' say so myself! ' LOCAL x%,y% found!=FALSE ' IF (NOT arexx_command!) AND mouse! AND ie_click! THEN ' ' Ignore mouse click if over the screen title bar ' IF event_y%<11 WHILE mouse! test_events(window%) WEND ENDIF ' old!=FALSE x%=event_x% y%=event_y% IF (x%>=array%(0) AND x%<=array%(2)) AND (y%>=array%(1) AND y%<=array%(3)) THEN ' WHILE mouse! IF (x%>=array%(0) AND x%<=array%(2)) AND (y%>=array%(1) AND y%<=array%(3)) THEN found!=TRUE ELSE found!=FALSE ENDIF IF found!<>old! THEN xor_gadget(window%,array%(0),array%(1),array%(2),array%(3)) ENDIF old!=found! x%=event_x% y%=event_y% test_events(window%) WEND ' IF found! THEN xor_gadget(window%,array%(0),array%(1),array%(2),array%(3)) ENDIF ENDIF ENDIF RETURN > PROCEDURE test_gadget_keypress(window%,VAR array%(),found!) ' ' If the boolean parameter FOUND! is true (i.e. if the gadget defined by ' the array ARRAY() has been selected) then this routine highlights the ' gadget while a key is depressed. This gives the effect which selects ' the appropriate gadget when a key is pressed. ' IF found! AND event_class%=&H400 AND (NOT playing_macro!) THEN ' xor_gadget(window%,array%(0),array%(1),array%(2),array%(3)) REPEAT test_events(window%) UNTIL (EVEN(PEEK(rawkey%)) AND event_class%=0) ' xor_gadget(window%,array%(0),array%(1),array%(2),array%(3)) ENDIF RETURN > PROCEDURE gadget_off(window%,VAR array%()) ' ' ReDraws a gadget which has already been created, but ghosts it to ' show that it has been de-selected. It then erases the contents of ' the coordinate array so that it cannot be clicked on. ' If the boolean, CLICKABLE!, is true then the gadget can still be ' selected but it will look ghosted, otherwise, it will not be able ' to be selected at all. ' IF currwindow%<>window% THEN activate(window%) ENDIF ' IF winptr%(window%)<>0 THEN ' RASTPORT {winptr%(window%)+50} GRAPHMODE 0 DEFFILL col1%,2,4 ' colour2(window%,col1%,backcol%) ' PBOX array%(0),array%(1),array%(2),array%(3) ' DEFFILL ,2,8 RASTPORT {winptr%(currwindow%)+50} GRAPHMODE 1 ' ENDIF ' array%(0)=0 array%(1)=0 array%(2)=0 array%(3)=0 ' RETURN > PROCEDURE number_gadget(window%,x%,y%,boxsize%,maxsize%,VAR number%,move%) ' ' Patches the String_Gadget routine so that it is possible to modify ' integer values directly (instead of just strings). ' LOCAL temp$ ' IF number%>=0 THEN temp$=STR$(number%) ELSE temp$="" ENDIF string_gadget(window%,x%,y%,boxsize%,maxsize%,temp$,move%) number%=MAX(INT(VAL(temp$)),0) RETURN > PROCEDURE refresh_number(window%,x%,y%,boxsize%,number%) ' ' Again, a patch for the Refresh_String routine which will work with ' integer parameters. ' LOCAL temp$ ' temp$=STR$(number%) refresh_string(window%,x%,y%,boxsize%,temp$) number%=VAL(temp$) RETURN > PROCEDURE number_group(window%,x%,y%,boxsize%,maxsize%,position%,VAR curpos%,number%,move%) ' ' See String_Group ... ' LOCAL active! ' active!=(position%=curpos%) check_mouse_click IF mouse! THEN IF (event_x%>=x%-4) AND (event_x%<=x%+boxsize%*8) THEN IF (event_y%>=y%-8) AND (event_y%<=y%+3) THEN active!=TRUE curpos%=position% ENDIF ENDIF ENDIF ' IF active! THEN number_gadget(window%,x%,y%,boxsize%,maxsize%,number%,move%) ENDIF RETURN > PROCEDURE string_group(window%,x%,y%,boxsize%,maxsize%,position%,VAR curpos%,text$,move%) ' ' This coordinates the control when there are multiple string gadgets on ' the screen at once. The POSITION parameter defines the order in which ' the gadgets are activated (CURPOS is the position of the currently ' active gadget). The routine also checks for a mouse click and will ' activate the current gadget if the mouse is clicked over it. ' LOCAL active! ' active!=(position%=curpos%) check_mouse_click IF mouse! THEN IF (event_x%>x%-4) AND (event_x%<=x%+boxsize%*8) THEN IF (event_y%>=y%-8) AND (event_y%<=y%+3) THEN active!=TRUE curpos%=position% ENDIF ENDIF ENDIF ' IF active! THEN string_gadget(window%,x%,y%,boxsize%,maxsize%,text$,move%) ENDIF RETURN > PROCEDURE create_newsize_gadget IF use_wbench! THEN x%=screenwidth%-26 y%=bottomline%+1 colour1(0,shadow1%) line(0,x%+3,y%+8,screenwidth%-12,y%+8) line(0,screenwidth%-12,y%+8,screenwidth%-12,y%+2) colour1(0,shadow2%) line(0,screenwidth%-12,y%+2,x%+3,y%+8) newsizegadget%(0)=x% newsizegadget%(1)=y% newsizegadget%(2)=screenwidth% newsizegadget%(3)=y%+10 ENDIF RETURN > PROCEDURE xor_gadget(window%,x1%,y1%,x2%,y2%) ' ' Deals with the selection rendering of a gadget - whether it will be ' XOR'ed or only the frame inverted. ' IF NOT alt_gadgets! THEN xor_region(window%,x1%,y1%,x2%,y2%) ELSE IF POINT(x1%,y1%)=shadow1% THEN draw_box(window%,x1%,y1%,x2%,y2%) ELSE draw_reverse_box(window%,x1%,y1%,x2%,y2%) ENDIF ENDIF RETURN ' ********** HOUSEWORK SUBROUTINES FOR DISPLAY & MESSAGE HANDLING *********** > PROCEDURE line(window%,x1%,y1%,x2%,y2%) IF winptr%(window%)<>0 THEN rport%={winptr%(window%)+50} IF use_wbench! AND window%=0 THEN ~Move(rport%,x1%+wboffset_x%,y1%+wboffset_y%) ~Draw(rport%,x2%+wboffset_x%,y2%+wboffset_y%) ELSE ~Move(rport%,x1%,y1%) ~Draw(rport%,x2%,y2%) ENDIF ENDIF RETURN > PROCEDURE box(window%,x1%,y1%,x2%,y2%) IF winptr%(window%)<>0 THEN rport%={winptr%(window%)+50} IF use_wbench! AND window%=0 THEN x1%=x1%+wboffset_x% x2%=x2%+wboffset_x% y1%=y1%+wboffset_y% y2%=y2%+wboffset_y% ~Move(rport%,x1%,y1%) ~Draw(rport%,x2%,y1%) ~Draw(rport%,x2%,y2%) ~Draw(rport%,x1%,y2%) ~Draw(rport%,x1%,y1%) ELSE ~Move(rport%,x1%,y1%) ~Draw(rport%,x2%,y1%) ~Draw(rport%,x2%,y2%) ~Draw(rport%,x1%,y2%) ~Draw(rport%,x1%,y1%) ENDIF ENDIF RETURN > PROCEDURE pbox(window%,x1%,y1%,x2%,y2%) IF winptr%(window%)<>0 THEN rport%={winptr%(window%)+50} IF use_wbench! AND window%=0 THEN ~RectFill(rport%,x1%+wboffset_x%,y1%+wboffset_y%,x2%+wboffset_x%,y2%+wboffset_y%) ELSE ~RectFill(rport%,x1%,y1%,x2%,y2%) ENDIF ENDIF RETURN > PROCEDURE text(window%,x%,y%,text$) IF winptr%(window%)<>0 THEN rport%={winptr%(window%)+50} IF use_wbench! AND window%=0 THEN ~Move(rport%,x%+wboffset_x%,y%+wboffset_y%) ~Text(rport%,V:text$,LEN(text$)) ELSE ~Move(rport%,x%,y%) ~Text(rport%,V:text$,LEN(text$)) ENDIF ENDIF RETURN > PROCEDURE colour1(window%,a%) IF winptr%(window%)<>0 THEN rport%={winptr%(window%)+50} ~SetAPen(rport%,a%) ENDIF RETURN > PROCEDURE colour2(window%,a%,b%) IF winptr%(window%)<>0 THEN rport%={winptr%(window%)+50} ~SetAPen(rport%,a%) ~SetBPen(rport%,b%) ENDIF RETURN > PROCEDURE graphmode(window%,mode%) IF winptr%(window%)<>0 THEN rport%={winptr%(window%)+50} ~SetDrMd(rport%,mode%) ENDIF RETURN > PROCEDURE 3d_box(window%,x1%,y1%,x2%,y2%,shadow1%,shadow2%) ' ' Draws a frame rectangle with the given top-left and bottom-right coords. ' The frame is drawn in a 3D-look and is used by procedures like CreateGadget ' and GetFile. ' IF winptr%(window%)<>0 THEN rport%={winptr%(window%)+50} ' IF use_wbench! AND window%=0 THEN x1%=x1%+wboffset_x% x2%=x2%+wboffset_x% y1%=y1%+wboffset_y% y2%=y2%+wboffset_y% ENDIF ' IF screencolours%>2 THEN ~SetAPen(rport%,shadow1%) ELSE ~SetAPen(rport%,1) ENDIF ~Move(rport%,x1%,y1%) ! bright horiz ~Draw(rport%,x2%-1,y1%) ~Move(rport%,x1%,y1%) ! bright vert1 ~Draw(rport%,x1%,y2%) ~Move(rport%,x1%+1,y1%) ! bright vert1 ~Draw(rport%,x1%+1,y2%-1) IF screencolours%>2 THEN ~SetAPen(rport%,shadow2%) ENDIF ~Move(rport%,x2%,y1%) ! dark vert1 ~Draw(rport%,x2%,y2%) ~Move(rport%,x2%-1,y1%+1) ! dark vert2 ~Draw(rport%,x2%-1,y2%) ~Move(rport%,x1%+1,y2%) ! dark horiz ~Draw(rport%,x2%,y2%) ENDIF RETURN > PROCEDURE draw_box(window%,x1%,y1%,x2%,y2%) ' ' Draws a frame rectangle with the given top-left and bottom-right coords. ' The frame is drawn in a 3D-look and is used by procedures like CreateGadget ' and GetFile. ' 3d_box(window%,x1%,y1%,x2%,y2%,shadow2%,shadow1%) RETURN > PROCEDURE draw_reverse_box(window%,x1%,y1%,x2%,y2%) ' ' Draws a frame rectangle with the given top-left and bottom-right coords. ' The frame is drawn in a 3D-look and is used by procedures like CreateGadget ' and GetFile. ' IF screencolours%>2 THEN 3d_box(window%,x1%,y1%,x2%,y2%,shadow1%,shadow2%) ENDIF RETURN > PROCEDURE scroll(dx%,dy%,x1%,y1%,x2%,y2%) IF winptr%(0)<>0 THEN ~SetBPen({winptr%(0)+50},0) IF use_wbench! THEN ~ScrollRaster({winptr%(0)+50},dx%,dy%,x1%+wboffset_x%,y1%+wboffset_y%,x2%+wboffset_x%,y2%+wboffset_y%) ELSE ~ScrollRaster({winptr%(0)+50},dx%,dy%,x1%,y1%,x2%,y2%) ENDIF ENDIF RETURN > PROCEDURE pattern_box(window%,x1%,y1%,x2%,y2%) ' ' Draws a filled in box which contains a pattern of dots. This is used for ' the border area which is used in the custom requesters by Request() ' IF winptr%(window%)<>0 THEN ' RASTPORT {winptr%(window%)+50} DEFFILL col2%,2,4 ' IF screencolours%>2 THEN colour2(window%,col2%,backcol%) ELSE colour2(window%,col1%,backcol%) ENDIF ' IF use_wbench! AND window%=0 THEN PBOX x1%+wboffset_x%,y1%+wboffset_y%,x2%+wboffset_x%,y2%+wboffset_y% ELSE PBOX x1%,y1%,x2%,y2% ENDIF ' DEFFILL ,2,8 RASTPORT {winptr%(0)+50} ' ENDIF RETURN > PROCEDURE request(maintext$,ltext$,rtext$,VAR numb%) ' ' Creates a custom requester which displays the message MAINTEXT$ with ' two gadgets containg the text LTEXT$ and RTEXT$ (for the left and ' right gadget strangely enuf!). If RTEXT$ is empty then only one gadget ' is displayed in the centre of the requester. ' The returned value numb is set as follows :- ' ' numb=1 if LEFT gagdet is hit (normally OKAY) ' numb=0 if RIGHT gadget is hit (normally CANCEL) ' ' The message text can have "|" characters imbedded in it to force ' a new line of text. RETURN of Y can be pressed to select the Okay ' gadget and ESCAPE of N can be pressed to select the Cancel gadget. ' LOCAL okay!,cancel!,size%,lines%,break%,loop%,po%,x%,hot1$,hot2$ ' ' Check to see if the requester has been called as a result ' of an ARexx command. If so, then exit immediately with ' the effect of clicking on the okay gadget ' IF arexx_command! THEN numb%=1 ELSE IF winptr%(3)=0 THEN ' ' Save the current pen colour definitions (requester will always use ' a predefined pen set) ' backcol2%=backcol% pen12%=pen1% backcol%=col0% pen1%=col1% ' ' Calculate size increment depending upon screen font size for ' the height of the window. ' IF winptr%(0)<>0 THEN wbscrdata%={winptr%(0)+46} ELSE wbscrdata$=STRING$(346,CHR$(0)) wbscrdata%=V:wbscrdata$ ~GetScreenData(wbscrdata%,44,1,0) ENDIF scr_offset%=PEEK(wbscrdata%+35)+DPEEK({wbscrdata%+40}+4)-10 ' ' Calculate the number of lines of text to be displayed (3 max) ' lines%=0 text$(0)=maintext$ FOR break%=1 TO 20 text$(break%)="" NEXT break% break%=INSTR(maintext$,"|") WHILE break%>0 AND lines%<20 text$(lines%)=LEFT$(maintext$,break%-1) lines%=lines%+1 maintext$=RIGHT$(maintext$,LEN(maintext$)-break%) text$(lines%)=maintext$ break%=INSTR(maintext$,"|") WEND ' ' Calculate the height of the requester and the largest string length ' hgt%=70+lines%*9+scr_offset% size%=0 FOR loop%=0 TO lines% text$(loop%)=LEFT$(text$(loop%),65) size%=MAX(LEN(text$(loop%)),size%) NEXT loop% ' ' Calculate the width of the requester ' lng%=(size%+8)*8 ' ' Work out the Hotkeys ... ' IF rtext$<>"" THEN hot1$=UPPER$(LEFT$(ltext$,1)) hot2$=UPPER$(LEFT$(rtext$,1)) ltext$="~"+ltext$ rtext$="~"+rtext$ ELSE hot1$=UPPER$(LEFT$(ltext$,1)) hot2$=CHR$(0) ltext$="~"+ltext$ ENDIF ' ' Open the requester window ... ' open_window(3,0,0,lng%,hgt%,"EdWord Pro Message") IF NOT unable_to_open_window! THEN ' IF screencolours%>2 THEN pattern_box(3,4,11+scr_offset%,lng%-5,hgt%-3) draw_reverse_box(3,15,15+scr_offset%,lng%-15,hgt%-30) ELSE pattern_box(3,2,11+scr_offset%,lng%-3,hgt%-2) draw_box(3,15,15+scr_offset%,lng%-15,hgt%-30) ENDIF colour1(3,backcol%) pbox(3,17,16+scr_offset%,lng%-17,hgt%-31) ' ' Display the message and the gadgets ' colour2(3,pen1%,backcol%) FOR loop%=0 TO lines% centre_text(3,text$(loop%),lng%,30+loop%*9+scr_offset%) NEXT loop% ' IF rtext$="" THEN create_gadget(3,(lng%/2)-(LEN(ltext$)+2)*4,hgt%-22,ltext$,reqokay%()) ELSE style(2) create_gadget(3,15,hgt%-22,ltext$,reqokay%()) style(0) create_gadget(3,lng%-9-(LEN(rtext$)+2)*8,hgt%-22,rtext$,reqcancel%()) ENDIF ' cancel!=FALSE REPEAT test_for_sleep(3) test_gadget(3,reqokay%(),okay!) IF rtext$<>"" THEN test_gadget(3,reqcancel%(),cancel!) ENDIF ' key$=UPPER$(event_key$) IF key$=CHR$(13) OR key$=hot1$ okay!=TRUE ELSE IF key$=CHR$(27) OR key$=hot2$ IF rtext$<>"" THEN cancel!=TRUE ELSE okay!=TRUE ENDIF ENDIF UNTIL cancel! OR okay! OR abortgadget! ' IF okay! THEN numb%=1 ELSE numb%=0 ENDIF ' ' Make gadets "click" if key pressed instead of mouse ' test_gadget_keypress(3,reqokay%(),okay!) test_gadget_keypress(3,reqcancel%(),cancel!) ' close_window(3) ELSE ' ' Cannot open window, so print message out to default CLI ' dosprint("EdWord V"+version$+" Message :") FOR loop%=0 TO lines% dosprint(text$(loop%)) NEXT loop% numb%=1 ENDIF ' backcol%=backcol2% pen1%=pen12% ELSE numb%=1 ENDIF ' ENDIF RETURN > PROCEDURE inform(text$) ' ' Displays a requester with one OKAY button ' IF arexx_command! THEN arexx_result(text$,5) ELSE request(text$,confirm$,"",x%) curkey$="" ENDIF RETURN > PROCEDURE tick_gadget(window%,x%,y%) ' ' Draws a WorkBench 2.0 style tick (for a boolean gadget) at the ' specified coordinates. ' colour1(window%,pen1%) line(window%,x%,y%+3,x%+3,y%+6) line(window%,x%+1,y%+3,x%+4,y%+6) line(window%,x%+2,y%+3,x%+4,y%+5) line(window%,x%+4,y%+6,x%+10,y%) line(window%,x%+5,y%+6,x%+11,y%) line(window%,x%+12,y%,x%+12,y%) RETURN > PROCEDURE big_swirl_gadget(window%,x%,y%) ' ' Draws a large WorkBench 2.0 style swirl (for a boolean gadget) at the ' specified coordinates ' colour1(window%,pen1%) line(window%,x%+1,y%,x%+7,y%) line(window%,x%,y%+1,x%,y%+7) line(window%,x%+1,y%+1,x%+1,y%+7) line(window%,x%+1,y%+8,x%+7,y%+8) line(window%,x%+7,y%+1,x%+7,y%+7) line(window%,x%+8,y%+1,x%+8,y%+7) line(window%,x%+5,y%+3,x%+10,y%+3) line(window%,x%+6,y%+4,x%+9,y%+4) colour1(window%,backcol%) line(window%,x%+7,y%+6,x%+8,y%+6) RETURN > PROCEDURE wee_swirl_gadget(window%,x%,y%) ' ' Draws a small WorkBench 2.0 style swirl (for a boolean gadget) at the ' specified coordinates ' colour1(window%,pen1%) line(window%,x%+1,y%,x%+7,y%) line(window%,x%,y%+1,x%,y%+5) line(window%,x%+1,y%+1,x%+1,y%+5) line(window%,x%+1,y%+6,x%+7,y%+6) line(window%,x%+7,y%+1,x%+8,y%+1) line(window%,x%+5,y%+2,x%+10,y%+2) line(window%,x%+6,y%+3,x%+9,y%+3) line(window%,x%+7,y%+4,x%+8,y%+4) RETURN > PROCEDURE alert(message$) ' ' Displays a message on the screen's title bar until a key is pressed ' or a mouse button clicked. ' LOCAL starttime ' IF arexx_command! THEN arexx_result(message$,5) ELSE IF NOT playing_macro! ghost_menus message(message$) ' IF ODD(PEEK(rawkey%)) THEN currawkey%=PEEK(rawkey%) WHILE PEEK(rawkey%)=currawkey% ! ignore current keypress/mouse WEND ENDIF ' starttime=TIMER REPEAT update_time flash_cursor wait_for_event(0) test_events(0) UNTIL ((event_class%>0) AND (event_class%<&H100000)) OR (TIMER>starttime+14*60) ' ENDIF ' message("") alerted!=TRUE RETURN > PROCEDURE up_scroll_arrow(window%,x%,y%) ' ' >>> DRAW THE UP SCROLL ARROW FOR THE PROPORTIONAL GADGET <<< ' colour1(window%,col1%) line(window%,x%,6+y%,x%+13,6+y%) line(window%,x%,5+y%,x%+13,5+y%) line(window%,x%+2,4+y%,x%+11,4+y%) line(window%,x%+4,3+y%,x%+9,3+y%) line(window%,x%+6,2+y%,x%+7,2+y%) draw_box(window%,x%-3,y%,x%+16,y%+8) RETURN > PROCEDURE dn_scroll_arrow(window%,x%,y%) ' ' >>> DRAW THE DOWN SCROLL ARROW FOR THE PROPORTIONAL GADGET <<< ' colour1(window%,col1%) line(window%,x%,y%+2,x%+13,y%+2) line(window%,x%,y%+3,x%+13,y%+3) line(window%,x%+2,y%+4,x%+11,y%+4) line(window%,x%+4,y%+5,x%+9,y%+5) line(window%,x%+6,y%+6,x%+7,y%+6) draw_box(window%,x%-3,y%,x%+16,y%+8) RETURN > PROCEDURE clear_screen ' ' Clears the textual part of the screen leaving the proportional ' gadget and status bar intact ' colour1(0,col0%) pbox(0,0,text_offset%,maxcol%*8+1,maxrow%*8+text_offset%) RETURN > PROCEDURE xor_region(window%,x1%,y1%,x2%,y2%) ' ' XOR's a rectangle of the screen. (i.e. complements the colour in that ' region). This routine is used by the Test_Gadget routine (and others) ' to show a gadget selection. ' graphmode(window%,3) colour1(window%,col2%) pbox(window%,x1%,y1%,x2%,y2%) graphmode(window%,1) RETURN > PROCEDURE xor_frame(window%,x1%,y1%,x2%,y2%) ' ' XOR's a rectanglar frame of the screen. (i.e. complements the colour ' around that region). This routine is used by the Drag_Split_Bar 2Êine. ' graphmode(window%,3) colour1(window%,col2%) box(window%,x1%,y1%,x2%,y2%) graphmode(window%,1) RETURN > PROCEDURE update_prop ' ' Works out where the proportional gadget should be and refreshes it ' IF (NOT supress_view!) AND (NOT prop_hit!) THEN proppos=(curline%-cursory%-1)/nooflines% propsize=MIN(maxrow%/nooflines%,1) proppos=INT(proppos*maxpot%) propsize=INT(propsize*maxpot%) display_prop(1) ENDIF RETURN > PROCEDURE error_handler ' ' In case of a fatal error ... Quit program and save current file to RAM: ' pheonix$="RAM:EdWord.Pheonix" tracy$="EdWord Has Encountered An Unrecoverable Error!|About To Quit Editor (Error Code "+STR$(ERR)+")" IF docupdated! OR lineupdated! THEN tracy$=tracy$+"|Saving Current File To "+CHR$(34)+pheonix$+CHR$(34) curfilename$=pheonix$ ENDIF ' inform(tracy$) ' IF curfilename$=pheonix$ THEN @save_file(FALSE) ENDIF close_down SYSTEM RETURN > PROCEDURE display_prop(col%) ' ' displays the proportional gadget in colour COL ' px1%=screenwidth%-17 px2%=screenwidth%-6 IF proppos+propsize=maxpot%-1 THEN proppos=proppos+1 ENDIF proppos=MAX(0,proppos) propsize=MIN(maxpot%-proppos,propsize) ' colour1(0,col0%) wb_offset%=use_wbench!*8 pbox(0,px1%+wb_offset%,11+prop_offset%,px2%+wb_offset%,11+proppos+prop_offset%) pbox(0,px1%+wb_offset%,13+proppos+propsize+prop_offset%,px2%+wb_offset%,13+maxpot%+prop_offset%) colour1(0,col%) pbox(0,px1%+wb_offset%,12+proppos+prop_offset%,px2%+wb_offset%,12+proppos+propsize+prop_offset%) RETURN > PROCEDURE memory_alert ' ' Displays a standard error message if we are running out of memory fairly ' fast. ' ' a$=CHR$(0)+CHR$(132)+CHR$(20) ' a$=a$+">>> EdWord V2.0 Fatal Error : OUT OF MEMORY <<<"+CHR$(0)+CHR$(0)+CHR$(0) ' ~DisplayAlert(0,VARPTR(a$),36) ' request("WARNING : Not Enough Memory|To Perfom Text Insertion !","WELL BUGGER ME!","",x%) RETURN > PROCEDURE delay_return(delay!) ' ' Optionally used after a DOS command has been executed to delay ' re-entry into EdWord. This is useful if the program being run ' does not already do this and so the user wishes to stay on the ' WBench screen until he (or she I suppose) has read the output. ' Then go back to EdWord in his (or its) own time ' LOCAL cli_lock% ' IF delay! THEN SETWTITLE "Press ANY KEY or RIGHT BUTTON to return to EdWord V"+version$+" " OPENW #3,80,100,494,10-workbench_2.0!,&H608,&H1100E ' ' Wait for an event in the window : CLOSEWINDOW, RAWKEY or MOUSEBUTTONS ' ~Wait(SHL(1,PEEK({WINDOW(3)+86}+15))) CLOSEW #3 ' WHILE MOUSEK<>0 WEND ENDIF RETURN > PROCEDURE menu_jump_table(number%,item%) ' ' The list of procedures that are to be performed on selection of any ' particular menu item. NUMBER = menu bar number, ITEM = number of the ' menu item on that bar. ' SELECT (number%*100+item%) ' ******* PROJECT MENU - Starts at 100 ******* CASE 101 erase_document CASE 103 open_file CASE 104 @save_file(FALSE) CASE 105 @save_as CASE 106 revert CASE 108 create_doc CASE 109 @remove_doc CASE 111 next_doc CASE 112 prev_doc CASE 113 select_doc CASE 115 iconify CASE 116 about CASE 118 buggeroff!=TRUE ' ******* FILE MENU - Starts at 200 ******* CASE 201 insert_file CASE 202 write_block CASE 204 print_document("Print Current File",docstart%,noofchars%) CASE 206 erase_file CASE 207 @rename_file CASE 209 chmod CASE 211 cursor_bof CASE 212 cursor_eof CASE 214 strip_chars CASE 216 set_tab_size CASE 217 toggle_mode ' ******* BLOCK MENU - Starts at 300 ******* CASE 301 start_of_block(lineadd%,0) CASE 302 end_of_block(lineadd%,0) CASE 303 vert_block_start CASE 304 vert_block_end CASE 305 block_off CASE 307 cut_block CASE 308 copy_block block_off CASE 309 insert_block CASE 310 erase_block CASE 311 print_document("Print Block",clipstart%,clipsize%) CASE 312 view_clipboard CASE 314 centre_line CASE 315 del_line CASE 316 undo_line CASE 317 del_to_eoln CASE 318 del_word ' ******* SEARCH MENU - Starts at 400 ******* CASE 401 jump_to_line CASE 403 find CASE 404 find_next CASE 405 find_previous CASE 406 find_replace CASE 408 find_hex CASE 409 goto_offset CASE 410 match_brackets CASE 412 set_mark(1) CASE 413 set_mark(2) CASE 414 set_mark(3) CASE 415 jump_to_mark(1) CASE 416 jump_to_mark(2) CASE 417 jump_to_mark(3) ' ******* UTILITIES MENU - Starts at 500 ******* CASE 501 insert_ascii CASE 503 case_text CASE 505 define_commands CASE 506 execute(1) CASE 507 execute(2) CASE 508 execute(3) CASE 510 system_status CASE 512 define_fkeys CASE 514 upperword lineupdated!=TRUE CASE 515 lowerword lineupdated!=TRUE CASE 517 preferences CASE 518 definitions ' ******* TOOLS MENU - Starts at 600 ******* CASE 601 stats CASE 602 occurence_count CASE 603 convert_tab2space CASE 604 repeat_text CASE 606 mini_calc CASE 608 sort_block CASE 610 new_screen_mode CASE 611 timed_saves CASE 612 colours CASE 614 toggle_split_screen CASE 615 switch_to_other_split CASE 617 undo_option ' ********** SCRIPT MENU - Starts at 700 ********** CASE 701 start_macro CASE 702 stop_macro CASE 703 playback_macro CASE 704 repeat_macro CASE 706 @load_a_macro CASE 707 @save_a_macro CASE 708 clear_macro CASE 710 arexx_interpreter CASE 711 arexx_script ENDSELECT RETURN > PROCEDURE menu_attr(menuno%,itemno%,newattr%) ' ' Changes the attribute of a menu item ' LOCAL menuadd% ' menuadd%=menu_strip% IF menuadd%<>0 THEN WHILE menuno%>1 AND LPEEK(menuadd%)<>0 menuadd%=LPEEK(menuadd%) menuno%=menuno%-1 WEND ' menuadd%=menuadd%+18 WHILE itemno%>=1 AND LPEEK(menuadd%)<>0 menuadd%=LPEEK(menuadd%) itemno%=itemno%-1 WEND ' commseq%=4 IF PEEK(menuadd%+26)<>0 THEN newattr%=newattr% OR commseq% ENDIF ' DPOKE menuadd%+12,newattr% ' ENDIF RETURN > PROCEDURE menu_text(menuno%,itemno%,text$) ' ' Changes the text held in a menu bar ' LOCAL menuadd%,loop% ' menuadd%=menu_strip% IF menuadd%<>0 THEN WHILE menuno%>1 AND LPEEK(menuadd%)<>0 menuadd%=LPEEK(menuadd%) menuno%=menuno%-1 WEND ' menuadd%=menuadd%+18 WHILE itemno%>=1 AND LPEEK(menuadd%)<>0 menuadd%=LPEEK(menuadd%) itemno%=itemno%-1 WEND ' menuadd%={LPEEK(menuadd%+18)+12} ' loop%=0 WHILE PEEK(menuadd%+loop%)<>0 IF loop% PROCEDURE ghost_menus ' ' This procedure will ghost any menu items which are not available ' to the user at the current time so that they cannot be selected ' These are basically the Block operations, (Cut,Copy,Erase,Write etc) ' IF winptr%(0)<>0 AND (NOT buggeroff!) THEN ' ' Ghost if no block selected ' IF blockon! THEN menuattr%=menuon% ELSE menuattr%=menuoff% ENDIF menu_attr(3,5,menuattr%) ! Block Off menu_attr(3,7,menuattr%) ! Cut Block menu_attr(3,8,menuattr%) ! Copy Block menu_attr(3,10,menuattr%) ! Erase Block ' ' Ghost Iconify if not under WorkBench 2.0 ' IF NOT workbench_2.0! THEN menu_attr(1,15,menuoff%) ! Iconify ENDIF ' ' Ghost if clipboard empty ' IF blockcopied! THEN menuattr%=menuon% ELSE menuattr%=menuoff% ENDIF menu_attr(2,2,menuattr%) ! Write Clip menu_attr(3,9,menuattr%) ! Insert Clip menu_attr(3,11,menuattr%) ! Print Clip menu_attr(3,12,menuattr%) ! View Clip menu_attr(6,8,menuattr%) ! Sort Clip ' ' Ghost if ARexx port not active ' IF rexxhostbase%<>0 THEN menuattr%=menuon% ELSE menuattr%=menuoff% ENDIF menu_attr(7,11,menuattr%) ! ARexx Script ' ' Ghost Revert option is document doesn't have a filename ' IF curfilename$<>"" THEN menuattr%=menuon% ELSE menuattr%=menuoff% ENDIF menu_attr(1,6,menuattr%) ! Revert ' ' Ghost Remove Doc if only one document ' IF noofdocs%>1 THEN menuattr%=menuon% ELSE menuattr%=menuoff% ENDIF menu_attr(1,9,menuattr%) ! Remove Doc menu_attr(1,11,menuattr%) ! Next Doc menu_attr(1,12,menuattr%) ! Previous Doc menu_attr(1,13,menuattr%) ! Select Doc ' ' Ghost Other Screen if Split Screen not in force ' IF split_screen! THEN menuattr%=menuon% ELSE menuattr%=menuoff% ENDIF menu_attr(6,15,menuattr%) ! Other Screen ENDIF RETURN > PROCEDURE test_keypress ' ' Acts upon any keypress that was entered into the main editor window ' IF winptr%(0)<>0 AND (NOT buggeroff!) THEN check_status_bar curkey$=event_key$ ' IF vi_mode! THEN IF curkey$<>"" ~DisplayBeep(scrptr%(1)) ENDIF ELSE ' ' Check to see if we have to damp the current keypress ' ignore_key_repeat(curkey$) ' ' **************** A PRINTABLE CHARACTER HAS BEEN HIT ********************* char_inserted!=FALSE IF NOT supress_view! THEN text2document(curkey$) ENDIF ' ' Only check the other keys if the character was not a printable ' character (should speed editing up a little bit) ' IF NOT char_inserted! THEN ' ********************** RIGHT CURSOR KEY PRESSED ********************* IF curkey$=rightarrow$ OR curkey$=ctrld$ THEN IF ie_alt! THEN cursor_eol ELSE IF ie_ctrl! cursor_far_right ELSE IF curkey$<>"" cursor_right ENDIF ' ********************** LEFT CURSOR KEY PRESSED ******************** ELSE IF curkey$=leftarrow$ OR curkey$=ctrls$ IF ie_alt! THEN cursor_bol ELSE IF ie_ctrl! cursor_far_left ELSE IF curkey$<>"" cursor_left ENDIF ' *********************** DOWN ARROW KEY PRESSED ******************** ELSE IF curkey$=dnarrow$ OR curkey$=ctrlx$ IF ie_alt! THEN cursor_eof ELSE IF ie_ctrl! cursor_bottom_of_screen ELSE IF curkey$<>"" cursor_down ENDIF ' ************************ UP ARROW KEY PRESSED ********************* ELSE IF curkey$=uparrow$ OR curkey$=ctrle$ IF ie_alt! THEN cursor_bof ELSE IF ie_ctrl! cursor_top_of_screen ELSE IF curkey$<>"" cursor_up ENDIF ' ********************* SHIFT + RIGHT KEY PRESSED ******************* ELSE IF curkey$=shiftright$ next_word ' ********************* SHIFT + LEFT KEY PRESSED ******************** ELSE IF curkey$=shiftleft$ prev_word ' ****************** SHIFT + DOWN ARROW KEY PRESSED ***************** ELSE IF curkey$=shiftdown$ OR curkey$=ctrlc$ page_down ' ******************* SHIFT + UP ARROW KEY PRESSED ****************** ELSE IF curkey$=shiftup$ OR curkey$=ctrlr$ page_up ' ********************* CTRL+T = GOTO TOP OF FILE ******************* ELSE IF curkey$=ctrlt$ cursor_bof ' ******************* CTRL+B = GOTO BOTTOM OF FILE ****************** ELSE IF curkey$=ctrlb$ IF ie_keypad! THEN supress_view!=TRUE caroline!=FALSE cursor_eof supress_view!=FALSE cursor_eol update_prop IF NOT caroline! THEN refresh_page ENDIF ELSE cursor_eof ENDIF ' *********************** CTRL+K = ERASE BLOCK ********************** ELSE IF curkey$=ctrlk$ AND blockon! erase_block ' ************************ CTRL+W = SAVE FILE *********************** ELSE IF curkey$=ctrlw$ @save_file(FALSE) ' ********************* CTRL + L = PRINT BLOCK ********************** ELSE IF curkey$=ctrll$ AND blockcopied! print_document("Print Block",clipstart%,clipsize%) ' ******************* THE RETURN KEY IS PRESSED ********************* ELSE IF curkey$=CHR$(13) line_feed ' ******************* DELETE CHARACTER BACKSPACE ******************** ELSE IF curkey$=CHR$(8) AND (ie_shift!) del_to_boln ' ******************* DELETE CHARACTER AT CURSOR ******************** ELSE IF curkey$=ctrlg$ del_char ELSE IF curkey$=CHR$(127) IF ie_shift! THEN IF shiftdel_word! THEN del_word ELSE del_to_eoln ENDIF ELSE del_char ENDIF ' ***************** CTRL + Y = DELETE CURRENT LINE ****************** ELSE IF curkey$=ctrly$ del_line ' *************** CTRL + U = UNDO LAST LINE DELETED ***************** ELSE IF curkey$=ctrlu$ undo_line ' **************** CTRL + Q = DELETE TO END OF LINE ***************** ELSE IF curkey$=ctrlq$ del_to_eoln ' ***************** CTRL + V = DELETE CURRENT WORD ****************** ELSE IF curkey$=ctrlv$ del_word ' **************** CTRL + N = DELETE TO END OF LINE ***************** ELSE IF curkey$=ctrln$ repeat_text ' ********************** CTRL + O = DELETE FILE ********************* ELSE IF curkey$=ctrlo$ erase_file ' ********************** CTRL + J = RENAME FILE ********************* ELSE IF curkey$=ctrlj$ @rename_file ' **************** CTRL + P = MODIFY FILE PROTECTION **************** ELSE IF curkey$=ctrlp$ chmod ' ******************* CTRL + A = REFRESH DISPLAY ******************** ELSE IF curkey$=ctrla$ refresh_view ' ***************** CTRL + F = MANUAL GLOBAL CASE ******************* ELSE IF curkey$=ctrlf$ manual_global_case ' ***************** CTRL + F6 = ZOOM CURSOR ****************** ELSE IF curkey$=f10$ AND ie_ctrl! AND (NOT arexx_hotkey!) zoom(TRUE) ' ********************** WAS AN F-KEY PRESSED? ********************** ELSE IF (curkey$>=f1$) AND (curkey$<=f10$) AND LEN(curkey$)=3 IF ie_ctrl! AND arexx_hotkey! THEN clare%=VAL(MID$(curkey$,2,1))+1 IF clare%>0 AND clare%<11 THEN IF arexx_script$(clare%)="" THEN inform("ARexx Script Filename Not Defined!|Use `Run ARexx Script' First.") ELSE send_rexx_command(arexx_script$(clare%)) ENDIF ENDIF ELSE insert_fkey(curkey$) ENDIF ' ********************** WAS AN F-KEY SHIFTED? **************************** ELSE IF LEFT$(curkey$,1)=CHR$(155) AND LEN(curkey$)=4 shift_fkey(curkey$) ' ********************** WAS SHIFT+TAB PRESSED? *************************** ELSE IF curkey$=shifttab$ IF PEEK(curradd%-1)=tab% THEN back_space_char ENDIF ' *************** CTRL + ~ = A LITTLE HIDDEN MESSAGE ********************** ELSE IF curkey$=CHR$(30) inform("All In All, It's Just Another Brick In The Wall.") ' *************** CTRL + | = A LITTLE HIDDEN MESSAGE ********************** ELSE IF curkey$=CHR$(28) inform("I'll Never Be Turned !|You Have Failed Your Highness.|I Am A Jedi, Like My Father Before Me.") ' *************** CTRL + _ = A LITTLE HIDDEN MESSAGE ********************** ELSE IF curkey$=CHR$(31) inform("And The 52 Daughters Of The Revolution,|Turn The Gold To Chrome.") ' ************* CTRL + ENTER = A LITTLE HIDDEN MESSAGE ******************** ELSE IF curkey$=CHR$(29) inform("There's A Faceless Cross On A Distant Hill, A Wasted Voice,|A Silent Scream. Where The Lovers Love And The Dreamers Dream,|You Stand And Dream Alone.") ' *************** CTRL + ] = A LITTLE HIDDEN MESSAGE ********************** ELSE IF curkey$=CHR$(0) inform("My Heart Is In The Highlands; My Heart Is Not Here.|My Heart Is In The Highlands, A-Chasing The Deer.") ' ***************** HELP KEY PRESSED = UNDO OPTION ************************ ELSE IF curkey$=helpkey$ undo_option ' ************* ALT + ESC PRESSED = INTERNAL MEM DISPLAY ****************** ELSE IF curkey$=CHR$(155) iconify ' alert("Internal Memory = "+STR$(FRE(0))+" bytes, DocStart = $"+HEX$(docstart)) ' ******************* RAMIGA + I = PASTE BLOCK ********************** ' ELSE IF (UPPER$(curkey$)="I" AND ie_ramiga!) AND blockcopied! ' insert_block ' ************* ALT + M = START RECORDING MACRO *************** ELSE IF event_code%=&H37 AND ie_alt! start_macro ' ************* ALT + N = STOP RECORDING MACRO *************** ELSE IF event_code%=&H36 AND ie_alt! stop_macro ' ************* ALT + B = PLAYBACK MACRO *************** ELSE IF event_code%=&H35 AND ie_alt! playback_macro ' ************* ALT + R = PLAYBACK MACRO *************** ELSE IF event_code%=&H13 AND ie_alt! repeat_macro ' ************* ALT + L = LOAD A MACRO *************** ELSE IF event_code%=&H28 AND ie_alt! @load_a_macro ' ************* ALT + S = SAVE A MACRO *************** ELSE IF event_code%=&H21 AND ie_alt! @save_a_macro ELSE ' ************************** FLASH THE CURSOR ************************* flash_cursor ! flash cursor if no key pressed ENDIF ENDIF ENDIF ENDIF RETURN > PROCEDURE use_numeric_pad ' ' GFA-Basic INKEY$ does not distinguish between the keyboard numbers ' and the numeric pad numbers. This procedure looks at the hardware ' rawkey code (CURKEY) and updates the string from INKEY$ (CURKEY$) ' to an equivalent cursor key if the keypress is on the numeric pad ' This allows the optional use of the numeric pad as a cursor pad. ' i.e. numeric pad = a cursor pad if KeyPad!=FALSE ' IF ie_lamiga! THEN ! Direct ASCII Entry mode ' amiga_character_insert ' ELSE IF ie_keypad! AND (NOT keypad!) ' SELECT ASC(event_key$) CASE 56 ! Numeric 8 (UP) event_key$=uparrow$ CASE 50 ! Numeric 2 (DOWN) event_key$=dnarrow$ CASE 52 ! Numeric 4 (LEFT) event_key$=leftarrow$ CASE 54 ! Numeric 6 (RIGHT) event_key$=rightarrow$ CASE 53 ! Numeric 5 event_key$="" CASE 57 ! Numeric 9 (PGUP) event_key$=shiftup$ CASE 51 ! Numeric 3 (PGDN) event_key$=shiftdown$ CASE 55 ! Numeric 7 (HOME) event_key$=ctrlt$ CASE 49 ! Numeric 1 (END) event_key$=ctrlb$ CASE 46 ! Numeric . (DEL) event_key$=CHR$(127) CASE 48 ! Numeric 0 (INS) toggle_mode event_key$="" ENDSELECT ' ENDIF ' IF numl_pressed! THEN ! Numeric ( (NUML) toggle_numlock event_key$="" ENDIF RETURN > PROCEDURE amiga_character_insert ' ' This procedure mimicks a little function found on MS-DOS machines. ' That is, if you press either LEFT AMIGA or RIGHT ALT and then type ' in the decimal ASCII value of a character (whilts keeping the Amiga ' or alt key depressed) then, when you release all keys, the character ' with that Ascii value is inserted into the text - This allows you to ' directly enter ANY character (if you know its ASCII value) ' ' If such any entry is made, then a string is returned which contains ' the "|" character followed by the character to be inserted. This is ' done so that the value is not confused with a corresponding keyress ' whic would perform a different function. ' LOCAL b$,numb% ' IF (NOT amiga_insert_mode!) THEN ' d_a_e$="" WHILE (event_class%<>&H400) OR (event_class%=&H400 AND ie_lamiga!) AND (LEN(d_a_e$)<3) AND (NOT mouse!) AND (event_class%<>&H80000) b$=event_key$ IF b$>="0" AND b$<":" THEN d_a_e$=d_a_e$+b$ ELSE IF b$<>"" d_a_e$=d_a_e$+" " ENDIF amiga_insert_mode!=TRUE test_events(currwindow%) WEND ' IF d_a_e$<>"" THEN numb%=VAL(d_a_e$) IF numb%>=0 AND numb%<256 THEN IF numb%=lf% AND (NOT in_gadget!) THEN event_key$=CHR$(13) ELSE event_key$="|"+CHR$(numb%) ENDIF ENDIF ENDIF ENDIF ' amiga_insert_mode!=FALSE ' RETURN > PROCEDURE ramiga_test ' ' Used to test for RIGHT AMIGA + X and RIGHT AMIGA + Q for use in ' the string gadget to provide compatibility with the Intuition gadget. ' It is called by the String_Gadget() routine. ' ' If RIGHT AMIGA + X is seleceted then an ESCAPE character is sent back ' If RIGHT AMIGA + Q is seleceted then a HELP character is sent back ' LOCAL helen$ ' IF ie_ramiga! THEN helen$=UPPER$(event_key$) ' IF helen$="X" THEN event_key$=CHR$(27) ENDIF ' IF helen$="Q" THEN event_key$=helpkey$ ENDIF ENDIF RETURN > PROCEDURE ignore_key_repeat(VAR curkey$) ' ' This routine looks to see if there is a key being currently ' pressed (by looking at $BFEC01). If not, then all queued ' events are discarded. This is used to provide a sort of ' keyboard damping effect so that keeping the finger pressed ' on a key doesn't result in excessive entries. ' IF (NOT no_damping!) AND (NOT playing_macro!) THEN IF EVEN(PEEK(rawkey%)) AND ie_repeat! THEN IF INSTR(non_repeat$,curkey$)<>0 OR curkey$=leftarrow$ OR curkey$=rightarrow$ OR curkey$=uparrow$ OR curkey$=dnarrow$ OR curkey$=shiftup$ OR curkey$=shiftdown$ THEN REPEAT test_events(currwindow%) UNTIL event_class%=0 curkey$="" ENDIF ENDIF ENDIF RETURN > PROCEDURE check_mouse_click ' ' Checks to see if the mouse button has been pressed and updates the ' status of the global variable MOUSE! and RMOUSE! accordingly. The routine ' also sets the vairable DOUBLE_CLICK! to true is a double click was ' performed with the left mouse button. ' IF event_class%=8 THEN ' SELECT event_code% CASE &H68 mouse!=TRUE CASE &HE8 mouse!=FALSE CASE &H69 rmouse!=TRUE CASE &HE9 rmouse!=FALSE ENDSELECT ' ENDIF ' IF mouse! THEN ' ' double click delay in 1/50th secs (100=2 secs) ' IF (TIMER<=last_mouse_timer+100) AND (NOT last_mouse!) AND ABS(event_x%-mousex_save%)<2 AND ABS(event_y%-mousey_save%)<2 THEN LET double_click!=TRUE ELSE LET double_click!=FALSE ENDIF last_mouse_timer=TIMER mousex_save%=event_x% mousey_save%=event_y% ENDIF ' last_mouse!=mouse! RETURN > PROCEDURE check_status_bar ' ' Checks to see if the user clicked over an area of the status bar ' and initiates a certain operation if this was the case. e.g. clicking ' over the `Line : 1' part of the status bar will bring up the Jump To ' Line requester. ' LOCAL check%,newregion!,oldregion!,status_click%,exit_check! ' IF mouse! THEN ' ' Check for a click over the window sizing gadget ' new_size_window(done!) IF NOT done! THEN ' status_click%=-1 status%(1)=bottomline%+2 status%(3)=bottomline%+10 exit_check!=FALSE old_alt_gadgets!=alt_gadgets! alt_gadgets!=FALSE check%=0 WHILE (check%<=8) AND (NOT exit_check!) status%(0)=statusgadget%(check%,0) status%(2)=statusgadget%(check%,1) test_gadget(0,status%(),exit_check!) IF exit_check! THEN status_click%=check% ELSE check%=check%+1 ENDIF WEND alt_gadgets!=old_alt_gadgets! ' ' Act on a status bar gadget selection ' SELECT status_click% CASE 0 ! Line jump_to_line CASE 1 ! Column find CASE 2 ! Tab set_tab_size CASE 3 ! Mode toggle_mode CASE 4 ! Clock change_time CASE 5 ! Curr Char toggle_hexascii CASE 6 ! NumL toggle_numlock CASE 7 ! Cas toggle_cas CASE 8 select_doc ENDSELECT ' ENDIF ENDIF RETURN > PROCEDURE wbench_box(x1%,y1%,x2%,y2%) ' ' Draws a rectangle on the workbench screen - used for my custom window ' size routine for when editor window on wbench screen. ' y2%=MIN(y2%-1,wbench_size%) x2%=MIN(x2%-1,wbench_len%) wbenchptr%={winptr%(0)+46} wbenchrport%=wbenchptr%+84 ~SetDrMd(wbenchrport%,2) ~Move(wbenchrport%,x1%,y1%) ~Draw(wbenchrport%,x2%,y1%) ~Draw(wbenchrport%,x2%,y2%) ~Draw(wbenchrport%,x1%,y2%) ~Draw(wbenchrport%,x1%,y1%) ~SetDrMd(wbenchrport%,1) RETURN > PROCEDURE refresh_window ' ' Used after user has resized the window or zoomed it. ' draw_status_bar init_prop update_tab update_line update_column update_docno update_mode update_case_flag update_prop update_time update_num_lock create_newsize_gadget draw_split_bar refresh_other_split sexysofie%=curradd% goto_line(curline%,TRUE,FALSE) curradd%=sexysofie% get_cursorx refresh_page update_prop RETURN > PROCEDURE new_size_window(VAR done!) ' ' my custom window sizing routine ... ' done!=FALSE IF use_wbench! THEN mx%=event_x% my%=event_y% wbench_len%=DPEEK({winptr%(0)+46}+12) hitx!=(mx%>=newsizegadget%(0)) AND (mx%<=newsizegadget%(2)) hity!=(my%>=newsizegadget%(1)) AND (my%<=newsizegadget%(3)) IF mouse! AND hitx! AND hity! THEN done!=TRUE ' xor_region(0,newsizegadget%(0),newsizegadget%(1)+1,newsizegadget%(2),newsizegadget%(3)) ' x1%=DPEEK(winptr%(0)+4) y1%=DPEEK(winptr%(0)+6) x2%=DPEEK(winptr%(0)+8)+x1%-1 y2%=MIN(my%+12,wbench_size%) yof%=DPEEK(winptr%(0)+10)-y2%+y1% xof%=x2%-mx% y2%=y2%+yof% x2%=mx%+xof%+1 REPEAT wbench_box(x1%,y1%,x2%,y2%) ' REPEAT test_events(0) check_mouse_click my%=MIN(MAX(event_y%+12+yof%,y1%+100),wbench_size%) mx%=MIN(MAX(event_x%+xof%+1,x1%+300),wbench_len%) UNTIL y2%<>my% OR (NOT mouse!) OR x2%<>mx% ' wbench_box(x1%,y1%,x2%,y2%) y2%=my% x2%=mx% UNTIL (NOT mouse!) ' newscreenres%=MIN(y2%-y1%,wbench_size%-y1%) newscreenwidth%=x2%-x1% IF newscreenres%<>DPEEK(winptr%(0)+10) OR newscreenwidth%<>DPEEK(winptr%(0)+8) THEN colour1(0,0) pbox(0,0,0,newscreenwidth%-wboffset_x%*2,newscreenres%-2-wboffset_y%) screenwidth%=newscreenwidth% ~SizeWindow(winptr%(0),newscreenwidth%-DPEEK(winptr%(0)+8),newscreenres%-DPEEK(winptr%(0)+10)) ' REPEAT wait_for_event(0) test_events(0) UNTIL event_class%=&H2 OR event_class%=&H400 ' old_bottomline%=bottomline% bottomline%=newscreenres%-13+windowfontsize% maxrow%=bottomline% DIV 8 maxcol%=(newscreenwidth%-32) DIV 8 indentsize%=maxcol% ' refresh_split_pos refresh_window resizes%=resizes%+1 ' ELSE xor_region(0,newsizegadget%(0),newsizegadget%(1)+1,newsizegadget%(2),newsizegadget%(3)) ENDIF ENDIF ENDIF ' RETURN > PROCEDURE install_busy_pointer ' ' Sets up the sprite data for a busy pointer in Chip memory ' (MEMF_CHIP=2) ' INLINE busypointerdata%,73 ' busypointer%=AllocMem(73,2) IF busypointer%<>0 THEN BMOVE busypointerdata%,busypointer%,73 ENDIF ' RETURN > PROCEDURE set_pointer(mode%) ' ' Mode = 0 : Sets the normal preferences pointer ' Mode <> 0 : Sets a WorkBench 2.0 style busy pointer (stopwatch) ' IF winptr%(0)<>0 THEN IF (mode%=0 AND (NOT supress_view!)) OR busypointer%=0 THEN ~ClearPointer(winptr%(0)) ~SetMenuStrip(winptr%(0),menu_strip%) ELSE ~SetPointer(winptr%(0),busypointer%,16,16,-6,0) ~ClearMenuStrip(winptr%(0)) ENDIF ENDIF RETURN ' ******************* OPERATION SYSTEM MESSAGE HANDLERS ********************* PROCEDURE test_events(win%) ' ' Uses the Exec library AmigaDOS function GetMsg() ' to check for any messages for the specified window ' WIN. Four global variables will have there values ' updated to the Class,Code,Qualifier and IAddress ' fields of the message (or contain 0 if no message) ' as well as a string, EVENT_KEY$, which contains the ' current keypress (if any) ' LOCAL message% ' ' Check for an event ' IF winptr%(win%)<>0 THEN ' message%=GetMsg({winptr%(win%)+86}) IF (message%<>0 AND (NOT supress_view!)) OR playing_macro! THEN ' ' Save the required fields and then ' Reply() to the message. ' event_class%=LPEEK(message%+20) event_code%=DPEEK(message%+24) event_qualifier%=DPEEK(message%+26) event_iaddress%=LPEEK(message%+28) event_x%=WORD{message%+32} event_y%=WORD{message%+34} ' record_event ! for the macro feature playback_event ! ' ie_ctrl!=AND(event_qualifier%,8)<>0 ie_lamiga!=AND(event_qualifier%,&H40)<>0 ie_ramiga!=AND(event_qualifier%,&H80)<>0 ie_keypad!=AND(event_qualifier%,&H100)<>0 ie_alt!=AND(event_qualifier%,&H10)<>0 OR AND(event_qualifier%,&H20)<>0 ie_shift!=AND(event_qualifier%,1)<>0 OR AND(event_qualifier%,2)<>0 ie_repeat!=AND(event_qualifier%,&H200)<>0 ie_click!=(event_class%=8) AND (event_code%=&H68) ' ' Convert the current RAWKEY keypress into an ASCII/ANSI stream ' raw_key_convert(event_key$) ' ' Keep track of the number of screen resizes made. ' IF event_class%=&H2 THEN resizes%=resizes%+1 ENDIF ' ' Test for a mouse click ... ' check_mouse_click ELSE ' ' Reset the globals to their initial values ' event_class%=0 event_code%=0 event_qualifier%=0 event_iaddress%=0 event_key$="" event_x%=WORD{winptr%(win%)+14} event_y%=WORD{winptr%(win%)+12} ie_click!=FALSE ENDIF ' ' Reply to the IntuiMessage ... ' IF message%<>0 THEN ~ReplyMsg(message%) ENDIF ELSE event_class%=0 ENDIF ' IF win%=0 THEN IF use_wbench! THEN IF (event_class%<>8) OR (event_qualifier% AND &HFF)=0 OR (NOT ie_click!) THEN event_x%=event_x%-wboffset_x% event_y%=event_y%-wboffset_y% ELSE ' ' Account for LAmiga+LAlt weirdness ' event_x%=WORD{winptr%(win%)+108} event_y%=WORD{winptr%(win%)+110} ENDIF ENDIF ENDIF RETURN > PROCEDURE wait_for_event(win%) ' ' Uses the exec.library AmigaDOS function Wait() to sleep until an event ' occurs in the specified window (WINDOWNO) e.g. CloseWindow, RawKey ... ' The processes will also wake up if there is a signal from an ARexx ' script in our ARexx port. ' IF winptr%(win%)<>0 THEN ' ' Get the Signal set for the editor's window ' Signal = 1L << window->UserPort->mp_SigBit ' signal1%=SHL(1,PEEK({winptr%(win%)+86}+15)) ' ' Get the Signal set for the ARexx port (if opened) ' signal2%=0 IF rexxhostbase%<>0 THEN signal2%=SHL(1,PEEK(arexxport%+15)) ENDIF ' ' And for the AppWindow (if WorkBench 2.0+) ' signal3%=0 IF appwindowport%<>0 THEN signal3%=SHL(1,PEEK(appwindowport%+15)) ENDIF ' ' Finally, we want the timer device to wake us up every 1/10th secs ' ' signal4=0 ' IF timer_dev! THEN ' DPOKE timer_req+28,9 ! io_Command = TD_ADDREQUEST ' LPOKE timer_req+14,timerport ! ' LPOKE timer_req+32,1 ! tv_secs ' LPOKE timer_req+36,500000 ! tv_micro ' ~SendIO(timer_req) ' signal4=SHL(1,PEEK(timerport+15)) ' ENDIF ' ' Now do an operating system sleep until an event occurs ... ' allsignals%=signal1% OR signal2% OR signal3% siglist%=Wait(allsignals%) ' ' Remove any non-complete timer events (do need them anymore) ' ' IF timer_dev! THEN ' ~AbortIO(timer_req) ' ~WaitIO(timer_req) ' ENDIF ' ' deal with AppWindow messages ... ' app_message!=FALSE IF ((siglist% AND signal3%)<>0) AND (signal3%<>0) THEN app_window_message app_message!=TRUE ENDIF ' ' Check for an arexx message ... ' arexx_message!=FALSE IF ((siglist% AND signal2%)<>0) AND (signal2%<>0) THEN arexx_message!=TRUE ENDIF ENDIF RETURN > PROCEDURE test_for_sleep(win%) ' ' This is called by all of EdWord's windows. It gets the current event ' for that window and goes to sleep if there are no events waiting. ' (It also refreshes the screen while we are at it) ' IF currwindow%<>win% THEN activate(win%) ENDIF ' test_events(win%) ' ' Go to sleep if there are no messages waiting for us ' IF event_class%=0 THEN wait_for_event(win%) ' ' Always display the current time ' update_time ENDIF ' abortgadget!=(event_class%=&H200) ' RETURN > PROCEDURE wait_for_editor_event ' ' Performs four functions :- ' ' i) Tests to see any menu item has been selected - if so, then its ' position is returned into the menu jump table ' ii) Tests for the CloseGadget being hit if EdWord is working on the ' WorkBench screen. ' iii) Otherwise, Peforms an OS sleep until an event is received ' iv) If the user clicks over the right mouse button, then the current ' input event stream should be flushed. ' ' ' >>>>>>>>>>>>>>> GET ANY OPERATING SYSTEM MESSAGES <<<<<<<<<<<<<<<<<< ' IF winptr%(0)<>0 THEN test_events(0) ' ' >>>>>>>>>> WBENCH WINDOW ZOOMED <<<<<<<<<<< ' IF use_wbench! AND ODD(resizes%) AND workbench_2.0! THEN ' ' Iconify the editor window ' ~ClearMenuStrip(winptr%(0)) REPEAT zoom_x%=DPEEK(winptr%(0)+4) zoom_y%=DPEEK(winptr%(0)+6) ' wait_for_event(0) test_events(0) UNTIL (event_class%=&H2 AND (DPEEK(winptr%(0)+10)>99)) OR event_class%=&H200 ~SetMenuStrip(winptr%(0),menu_strip%) ' updates!=FALSE IF event_class%=&H200 THEN backup_curr_doc FOR jody%=0 TO noofdocs%-1 IF (docupdated!(jody%) OR lineupdated!(jody%)) THEN updates!=TRUE ENDIF NEXT jody% buggeroff!=TRUE ENDIF ' IF (event_class%=&H200 AND updates!) THEN ' ' Call the ZipWindow() routine to unzoom the window ' clear_registers reg%(8)=winptr%(0) reg%(14)=_IntBase RCALL _IntBase-&H1F8,reg%() REPEAT wait_for_event(0) test_events(0) UNTIL DPEEK(winptr%(0)+10)>99 AND event_class%=&H2 ENDIF ' ignore_messages refresh_window ' ENDIF ' ' >>>>>>>>>>>>> WORK OUT WHICH MENU ITEM WAS SELECTED <<<<<<<<<<<<<<< ' IF event_class%=&H100 THEN ! MenuPick = $100 alerted!=FALSE IF event_code%<>&HFFFF THEN ! $ffff = no selection ' ' Work out which menu has been selected ' menuno%=(event_code% AND &X11111)+1 menuitem%=ROR((event_code% AND &X11111100000),5)+1 menu_jump_table(menuno%,menuitem%) ghost_menus ENDIF ENDIF ' ' >>>>>>>>>>>>>>> CLOSE GADGET CLICKED (WBENCH ONLY) <<<<<<<<<<<<<<<< ' IF event_class%=&H200 THEN ! CloseWindow = $200 buggeroff!=TRUE ENDIF ' ' >>>>>>>>>>> DEAL WITH APPWINDOW MESSAGES <<<<<<<< ' IF app_message! THEN IF appfilename$<>"" THEN filename$=appfilename$ confirm_new_file("FORGET IT") @load_data ENDIF app_message!=FALSE ENDIF ' ' >>>>>>>>> TEST FOR AN AREXX MESSAGE <<<<<<<<< ' IF arexx_message! THEN test_for_arexx(rexxmsg%) IF rexxmsg%<>0 THEN act_on_arexx(rexxmsg%) ENDIF arexx_message!=FALSE ENDIF ' ' >>>>>>>>>>> WAIT FOR EVENT <<<<<<<< ' IF (event_class%=0) AND (NOT arexx_message!) AND (NOT app_message!) THEN ' ghost_menus wait_for_event(0) ' ENDIF ENDIF RETURN > PROCEDURE ignore_messages ' ' Deletes all waiting messages for the main text editor window ' (if it is opened). This is used to clear the Input Event stream. ' IF (NOT playing_macro!) THEN REPEAT test_events(0) UNTIL event_class%=0 ENDIF rmouse!=FALSE mouse!=FALSE RETURN > PROCEDURE open_console_device ' ' Opens the console device and finds the base address of ' the Console Library which is stored in the io_Device ' field of the IORequest structure returned by OpenDevice. ' This library base address is stored in the global ' variable CONSOLELIBRARY and is required for RawKeyConvert() ' LOCAL conname$ ' consolelibrary%=0 console_req%=AllocMem(48,&H10001) IF console_req%<>0 THEN conname$="console.device"+CHR$(0) IF OpenDevice(V:conname$,-1,console_req%,0)=0 THEN consolelibrary%=LPEEK(console_req%+20) ENDIF ENDIF ' ' If under WorkBench 2.0, use the KeyMap library instead of console device ' keymapname$="keymap.library"+CHR$(0) keymapbase%=OpenLibrary(V:keymapname$,37) ' RETURN > PROCEDURE close_console_device ' ' This will close a console device which has been previously ' opened. Checks are made to see that the device is currently ' open. ' IF consolelibrary%<>0 THEN ~CloseDevice(console_req%) IF console_req%<>0 THEN ~FreeMem(console_req%,48) ENDIF ENDIF ' IF keymapbase%<>0 THEN ~CloseLibrary(keymapbase%) ENDIF ' RETURN > PROCEDURE raw_key_convert(VAR buffer$) ' ' This procedure calls the RawKeyConvert() function of the console ' library (offset -48). To do this, the console device must first ' be opened and we must now create an InputEvent message which tells ' the it about the current keypress. The current key, if any, is ' returned through the parameter BUFFER$. ' buffer$="" IF event_class%=&H400 AND consolelibrary%<>0 THEN ' ' Create an InputEvent structure for RawKeyConvert() ' numl_pressed!=(event_code%=&H5A) AND ie_keypad! AND (ie_alt! OR ie_ctrl!) ' input_event%=AllocMem(22,&H10001) IF input_event%<>0 THEN POKE input_event%+4,1 ! ie_Class = IECLASS_RAWKEY DPOKE input_event%+6,event_code% ! ie_Code = msg->Code DPOKE input_event%+8,event_qualifier% ! ie_Qualifier = msg->Qualifier LPOKE input_event%+10,LPEEK(event_iaddress%) ! ie_Addr = msg->IAddress ' ' Create a buffer to put the vanilla text into ' buffer$=SPACE$(20) ' ' Now call RawKeyConvert() .... ' clear_registers reg%(8)=input_event% ! input event reg%(9)=V:buffer$ ! buffer address reg%(1)=20 ! buffer size ' ' If WorkBench 2.0 then use MapRawKey() ' Else use RawKeyConvert() ' IF keymapbase%<>0 THEN reg%(14)=keymapbase% ! keymap library base address RCALL keymapbase%-&H2A,reg%() ELSE reg%(14)=consolelibrary% ! console library base address RCALL consolelibrary%-48,reg%() ENDIF ' ~FreeMem(input_event%,22) ' ' And strip any characters from the buffer which weren't ' used (RawKeyConvert() returns the number of characters ' placed in the buffer in D0 (-1=Buffer too small)) ' IF reg%(0)>0 THEN buffer$=LEFT$(buffer$,reg%(0)) ELSE buffer$="" ENDIF ' ' Deal with Numeric Pad support, NumL feature and Direct ' ASCII Entry facility. ' use_numeric_pad ENDIF ENDIF RETURN > PROCEDURE app_window_message ' ' Handles any App Window messages and updates the string APPFILENAME$ ' to contain the name of the file selected or a null string for none. ' appfilename$="" appmsg%=GetMsg(appwindowport%) IF appmsg%<>0 THEN ' IF DPEEK(appmsg%+20)=7 THEN ! If MTYPE_APPWINDOW message ' ' Get the AppWindow filename's path ' applock%={{appmsg%+34}} ! get msg^.wb_ArgList^.wa_Lock fexpandlock(applock%,appfilename$) ! get filename's path IF appfilename$<>"" THEN ' ' Append an "/" symbol if not root directory ' IF RIGHT$(appfilename$,1)<>":" AND RIGHT$(appfilename$,1)<>"/" THEN appfilename$=appfilename$+"/" ENDIF ' ' Append AppWindow filename to the path ' appchar%={{appmsg%+34}+4} WHILE PEEK(appchar%)<>0 appfilename$=appfilename$+CHR$(PEEK(appchar%)) appchar%=appchar%+1 WEND ENDIF ' ENDIF ' ~ReplyMsg(appmsg%) ENDIF ' RETURN > PROCEDURE open_timer ' ' Open the timer device so that we can receive timer events ' I am using the UNIT_MICROHZ (0) clock because I don't need ' a precise and fast count (only "prods" every so often) ' ' LOCAL timername$ ' ' timer_dev!=FALSE ' timername$="timer.device"+CHR$(0) ' ' timerport=CreatePort(0,0) ' IF timerport<>0 THEN ' timer_req=CreateExtIO(timerport,62) ' IF timer_req<>0 THEN ' IF OpenDevice(V:timername$,0,timer_req,0)=0 THEN ' timer_dev!=TRUE ' ENDIF ' ENDIF ' ENDIF RETURN > PROCEDURE close_timer ' ' Closes the timer device as opened by the above procedure ' ' IF timer_dev! THEN ' ~CloseDevice(timer_req) ' ENDIF ' ' IF timer_req<>0 THEN ' @delete_ext_io(timer_req,62) ' ENDIF ' ' IF timerport<>0 THEN ' ~DeletePort(timerport) ' ENDIF RETURN ' ************************ MACHINE CODE ROUTINES **************************** > PROCEDURE install_mcode ' ' Allocates memory for the machine code routines and copies these ' procedures into memory. Then sets the start addresses of each routine. ' (This is done by loading the actual binary machine code data into INLINE ' statements.) The Machine code routines include :- ' ' NextLine(Address) ' PrevLine(Address,DocStart) ' MakeNullString(Buffer,Size,LineAdd) ' CountLines(DocStart,NoOfChars,VAR NoOfLines) ' ConvertString(Address,MaxBufSize,TabSize,VAR Buffer) ' FindCursor(LineAdd,CurrAdd,TabSize,VAR CursorX) ' FindString(Address,Found!,Forward!,Find$,DocStart,NoOfChars,LEN(text$),CaseDep!) ' WordCount(Address,MaxBytes,VAR Userquit) ' MatchBrackets(Address,Depth,Open$,Close$,Direction) ' IsKeyword(Keywords,Address,ArrayPtr,Size,IsKey!) ' PatchMenus(WindowHandle) ' ppDecrunchBuffer(EndCrun,DecrBuff,EffPtr,Col) ' StripChars(DocStart,NoOfChars,NoOfLines,LookUpTable) ' Tabs2Space(DocStart,NoOfChars,MemLimit,TabSize) ' SortArray(*Array$(),Size) ' ' Documentation for these routines are provided in the actual assembly ' source code listings (stored separately). ' INLINE mc68000nextline%,12 INLINE mc68000prevline%,18 INLINE mc68000makestring%,58 INLINE mc68000countlines%,28 INLINE mc68000convertstring%,72 INLINE mc68000findcursor%,42 INLINE mc68000findstring%,128 INLINE mc68000wordcount%,413 INLINE mc68000matchbrackets%,52 INLINE mc68000iskeyword%,539 INLINE mc68000ppdecrunch%,190 INLINE mc68000stripchars%,57 INLINE mc68000tabs2space%,224 INLINE installmenusdata%,8885 ' mc68000installmenus%=AllocMem(8900,1) IF mc68000installmenus%<>0 THEN BMOVE installmenusdata%,mc68000installmenus%,8885 ELSE buggeroff!=TRUE ENDIF RETURN > PROCEDURE clear_registers ' ' Initialises the array REG() to hold all zeros. This array is ' used by the RCALL statememt to call machine language programs ' and reseting its contents is effective to reseting d0-d7 and ' a0-a6 to equal zero. It would be wise to call these before ' setting up your own parameters - just in case you know! ' LOCAL clare% ' FOR clare%=0 TO 15 reg%(clare%)=0 NEXT clare% RETURN ' ************************* POWERPACKER DECRUNCH **************************** > PROCEDURE decrunch_powerpacker ' ' decrunches a powerpacker file if PP Detect is on. The routine makes use ' of the ppDecrunchBuffer function extracted from the powerpacker.library ' and stored in an INLINE in ppdecrunchbuffer_mc68000() so that it does ' not actually require the presence of the powerpacker.library. ' ' ' PowerPacker Crunched File Format = ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' 1 longword identifier = PP20 or PX20 ' (1 word checksum if file encrypted i.e. PX20) ' 1 longword efficiency ' X longwords of crunched data ' 1 longword of decrunch information ' ' N.B. The decrunch buffer size can be found by looking at the decrunch ' information longword at the end of the file and shifting it 8 bits ' to the right (i.e. DecrInfo << 8). ' ' ' Function call "ppDecrunchBuffer" format (offset = -$24) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Void ppDecrunchBuffer(EndCrun {A0},DecrBuff {A1},EffPtr {A2}, Col {D0}); ' ' where, EndCrun = pointer to first byte after the decrunch information ' DecrBuff = pointer to start of decrunch buffer (+8 safety bytes) ' EffPtr = pointer to tje efficiency longword ' Col = decrunch colour (2=pointer) ' LOCAL pp20%,px20%,efficiency%,decrunch_size%,docstart2% ' pp20%=&H50503230 ! Longword which defines string "PP20" px20%=&H50583230 ! Longword which defines string "PX20" ' IF pp_detect! AND docstart%<>0 THEN hide_cursor!=FALSE ' ' File is a protected powerpacker file ... (not supported) ' IF {docstart%}=px20% THEN inform("PowerPacker File Is Password Encrypted|Cannot Decrunch It!") ELSE IF {docstart%}=pp20% ' ' File is a standard powerpacker file ... so decrunch it ' noofchars%=noofchars%+false_eof! efficiency%=docstart%+4 ! second longword decrunch_size%=SHR({docstart%+noofchars%-4},8) ! last longword in file ' ' Allocate the memory for the new file size ... ' temp_size%=decrunch_size%+playspace% ! defined by Load_Data docstart2%=AllocMem(temp_size%,1) endcrun%=docstart%+noofchars% IF docstart2%<>0 THEN message("Decrunching ...") ' ' Now call the ppDecrunchBuffer routine from the powerpacker.library ' clear_registers reg%(0)=2 ! D0 = decrunch colour effect (pointer) reg%(8)=endcrun% ! A0 = just after last byte of crunched data reg%(9)=docstart2% ! A1 = beginning of memory to decrunch to (+8 safety bytes) reg%(10)=efficiency% ! A2 = pointer to efficiency longword RCALL mc68000ppdecrunch%,reg%() ! call ppDecrunchBuffer ' ' Forget about the crunched file and make the decrunched file the ' current document. ' ~FreeMem(docstart%,memorysize%) memorysize%=temp_size% docstart%=docstart2% curradd%=docstart% lineadd%=docstart% topadd%=docstart% noofchars%=decrunch_size% false_eof!=FALSE ELSE inform("Cannot Decrunch PowerPacker File|Not Enough Memory!") ENDIF ENDIF hide_cursor!=TRUE ENDIF RETURN > PROCEDURE decrunch_buffer(VAR buffer%,size%) ' ' same but for insert file ' LOCAL pp20%,px20%,efficiency%,decrunch_size%,buffer2% ' pp20$="PP20" ! Longword which defines string "PP20" px20$="PX20" ! Longword which defines string "PX20" ' IF pp_detect! AND buffer%<>0 THEN hide_cursor!=FALSE ' ' File is a protected powerpacker file ... (not supported) ' thelineadd%=buffer% fuckoff$="" FOR fuckoff%=0 TO 3 fuckoff$=fuckoff$+CHR$(PEEK(buffer%+fuckoff%)) NEXT fuckoff% ' IF fuckoff$=px20$ THEN inform("PowerPacker File Is Password Encrypted|Cannot Decrunch It!") ELSE IF fuckoff$=pp20$ ' ' File is a standard powerpacker file ... so decrunch it ' padshift%=buffer% MOD 4 IF padshift%>0 THEN padshift%=4-padshift% BMOVE buffer%,buffer%+padshift%,docstart%+noofchars%-thelineadd%+size% buffer%=buffer%+padshift% ENDIF ' efficiency%=buffer%+4 ! second longword decrunch_size%=SHR({buffer%+size%-4},8) ! last longword in file ' ' Check that decrunched file will fit in memory buffer ' IF memorysize%-memlow%0 THEN message("Decrunching Block ...") ' ' Now call the ppDecrunchBuffer routine from the powerpacker.library ' clear_registers reg%(0)=2 ! D0 = decrunch colour effect (pointer) reg%(8)=endcrun% ! A0 = just after last byte of crunched data reg%(9)=buffer2% ! A1 = beginning of memory to decrunch to (+8 safety bytes) reg%(10)=efficiency% ! A2 = pointer to efficiency longword RCALL mc68000ppdecrunch%,reg%() ! call ppDecrunchBuffer ' ' Forget about the crunched file and make the decrunched file the ' current document. ' delta%=decrunch_size%-size% BMOVE thelineadd%,thelineadd%+delta%-padshift%,docstart%+noofchars%-thelineadd%+size%+padshift% BMOVE buffer2%,thelineadd%,decrunch_size% buffer%=buffer%-padshift% ~FreeMem(buffer2%,decrunch_size%) size%=decrunch_size% ELSE BMOVE buffer%,buffer%-padshift%,docstart%+noofchars%-thelineadd%+size% buffer%=thelineadd% inform("Cannot Decrunch PowerPacker File|Not Enough Memory!") ENDIF ENDIF ENDIF hide_cursor!=TRUE ENDIF RETURN > PROCEDURE decrunch_keywords(VAR buffer%,size%) ' ' same but for insert file ' LOCAL pp20%,px20%,efficiency%,decrunch_size%,buffer2% ' pp20%=&H50503230 ! Longword which defines string "PP20" px20%=&H50583230 ! Longword which defines string "PX20" ' IF buffer%<>0 THEN hide_cursor!=FALSE ' ' File is a protected powerpacker file ... (not supported) ' IF {buffer%}=px20% THEN inform("PowerPacker File Is Password Encrypted|Cannot Decrunch It!") ELSE IF {buffer%}=pp20% ' ' File is a standard powerpacker file ... so decrunch it ' efficiency%=buffer%+4 ! second longword decrunch_size%=SHR({buffer%+size%-4},8) ! last longword in file ' ' Allocate the memory for the new file size ... ' buffer2%=AllocMem(decrunch_size%,1) endcrun%=buffer%+size% IF buffer2%<>0 THEN ' ' Now call the ppDecrunchBuffer routine from the powerpacker.library ' clear_registers reg%(0)=2 ! D0 = decrunch colour effect (pointer) reg%(8)=endcrun% ! A0 = just after last byte of crunched data reg%(9)=buffer2% ! A1 = beginning of memory to decrunch to (+8 safety bytes) reg%(10)=efficiency% ! A2 = pointer to efficiency longword RCALL mc68000ppdecrunch%,reg%() ! call ppDecrunchBuffer ' ' Forget about the crunched file and make the decrunched file the ' current document. ' ~FreeMem(buffer%,size%) buffer%=buffer2% size%=decrunch_size% ELSE inform("Cannot Decrunch PowerPacker File|Not Enough Memory!") ENDIF ENDIF hide_cursor!=TRUE ENDIF RETURN ' ***************************** AREXX SUPPORT ******************************* > PROCEDURE open_arexx ' ' Opens the rexxhost.library and returns its base address in the ' variable REXXHOSTBASE. First of all, we try to open the library ' rexxsyslib.library because rexxhost.library needs it and if ' it can't find it then it will crash the Amiga so we must check ' for it before hand. ' LOCAL lib$,temp% ' ' Set the default port name to that of any error and try to open ' the rexxsyslib.library. ' defaultname$="EDWORD" ' lib$="rexxsyslib.library"+CHR$(0) rexxsysbase%=OpenLibrary(V:lib$,0) IF rexxsysbase%<>0 THEN ' ' If rexxsyslib.library found, then close it and open the ' rexxhostbase.library ' ~CloseLibrary(rexxsysbase%) lib$="rexxhost.library"+CHR$(0) rexxhostbase%=OpenLibrary(V:lib$,34) IF rexxhostbase%<>0 THEN ' ' This routine creates an ARexx port for our program. If the ' routine fails (because there is already an ARexx port by the ' same name) then it will try again but with an appended number ' to the name in order to differentiate between the current one. ' The routine returns the name of the port which was allocated ' and sets the global variable AREXXPORT as a pointer to the port. ' arexx_port_name$=defaultname$ count%=1 ' ' Count lets us have more than one version of the program ' running at the same time with separate ARexx ports. ' e.g. PORT, PORT2, PORT3, PORT4 etc. ' REPEAT portname$=arexx_port_name$+CHR$(0) create_rexx_host(V:portname$,arexxport%) IF arexxport%=0 THEN count%=count%+1 arexx_port_name$=defaultname$+STR$(count%) ENDIF UNTIL arexxport%<>0 ELSE arexx_port_name$="no rexxhost.library!" ENDIF ELSE arexx_port_name$="no rexxsyslib.library!" ENDIF RETURN > PROCEDURE close_arexx ' ' This routine removes our ARexx port and closes the ' rexhost.library (assuming we have already opened it) ' IF rexxhostbase%<>0 THEN delete_rexx_host(arexxport%) ~CloseLibrary(rexxhostbase%) ENDIF RETURN > PROCEDURE test_for_arexx(VAR rexxmsg%) ' ' Check to see if there is an ARexx message ' rexxmsg%=0 IF rexxhostbase%<>0 THEN get_rexx_msg(arexxport%,0,rexxmsg%) ENDIF RETURN > PROCEDURE act_on_arexx(VAR rexxmsg%) ' ' This is the routine which actually looks to see if ARexx ' has sent us any commands to our port and acts upon them ' if this is the case. ' LOCAL cmdline$ ' get_rexx_command(rexxmsg%,cmdline$) ' ' Now act upon the command which we have received ' arexx_command(cmdline$,ret1%,ret2%,result%) ' ' Reply to the ARexx command because the ARexx script is ' halted until the message has been replied to ' reply_rexx_command(rexxmsg%,ret1%,ret2%,result%) ' RETURN > PROCEDURE create_rexx_host(hostname%,VAR result%) ' ' rexxhost.library library function extracted from .fd file. ' Creates an ARexx port for a program. ' ' HOSTNAME = pointer to name of the ARexx port (i.e. a string) ' RESULT = address of the created ARexx port ' clear_registers reg%(8)=hostname% reg%(14)=rexxhostbase% RCALL rexxhostbase%-30,reg%() result%=reg%(0) RETURN > PROCEDURE delete_rexx_host(messageport%) ' ' rexxhost.library library function extracted from .fd file. ' Removes an ARexx port from a program. ' ' MESSAGEPORT = address of the ARexx port to be removed ' clear_registers reg%(8)=messageport% reg%(14)=rexxhostbase% RCALL rexxhostbase%-36,reg%() RETURN > PROCEDURE send_rexx_command(scriptname$) ' ' rexxhost.library library function extracted from .fd file. ' Executes an ARexx script file. ' ' SCRIPTNAME$ = filename of the ARexx script ' IF scriptname$<>"" AND rexxhostbase%<>0 THEN ' IF INSTR(scriptname$," ")=0 THEN clare$=scriptname$ ELSE clare$=LEFT$(scriptname$,INSTR(scriptname$," ")-1) ENDIF ' IF EXIST(clare$) OR EXIST(clare$+".REXX") THEN scriptname$=scriptname$+CHR$(0) clear_registers reg%(8)=arexxport% reg%(9)=V:scriptname$ reg%(14)=rexxhostbase% RCALL rexxhostbase%-42,reg%() IF reg%(0)=0 THEN inform("ARexx Server Not Active|Run RexxMast First.") ENDIF ELSE file_not_found(scriptname$) ENDIF ENDIF RETURN > PROCEDURE reply_rexx_command(rexxmessage%,primary%,secondary%,result%) ' ' rexxhost.library library function extracted from .fd file. ' Replies to an ARexx command passed into our port. ' ' REXXMESSAGE = pointer message passed to ARexx port ' PRIMARY = return code one ' SECONDARY = return code two ' RESULT = Pointer to text string ' clear_registers reg%(8)=rexxmessage% reg%(0)=primary% reg%(1)=secondary% reg%(9)=result% reg%(14)=rexxhostbase% RCALL rexxhostbase%-54,reg%() RETURN > PROCEDURE get_rexx_command(rexxmessage%,VAR result$) ' ' rexxhost.library library function extracted from .fd file. ' Gets an ARexx command from a message in the ARexx port. ' ' REXXMESSAGE = pointer to ARexx message ' RESULT$ = The command passed through the ARexx port ' clear_registers reg%(8)=rexxmessage% reg%(14)=rexxhostbase% RCALL rexxhostbase%-60,reg%() result$=CHAR{reg%(0)} RETURN > PROCEDURE get_rexx_msg(rexxmessage%,wait%,VAR result%) ' ' rexxhost.library library function extracted from .fd file. ' Looks for any messages in our ARexx port. ' ' REXXMESSAGE = pointer to our ARexx port ' WAIT = bolean (True/False) whether to wait for message ' RESULT = Pointer to ARexx message (or zero if none) ' clear_registers reg%(8)=rexxmessage% reg%(0)=wait% reg%(14)=rexxhostbase% RCALL rexxhostbase%-108,reg%() result%=reg%(0) RETURN > PROCEDURE arexx_interpreter ' ' This routine displays a simple window with a single string gadget ' in it to allow the user to enter ARexx commands directly. This is ' mainly a debugging facility for me, but it may also be handy for ' the general user. ' hide_cursor!=FALSE open_window(4,130,50,450,86,"ARexx Command Line") IF NOT unable_to_open_window! THEN ' arexx_interpreter!=TRUE ' colour2(4,pen1%,backcol%) text(4,22,28,"Enter ARexx Macro :") text(4,22,46," Previous Result :") text(4,188,46,CHR$(48)) IF screencolours%>2 THEN draw_reverse_box(4,184,38,420,48) ELSE draw_box(4,184,38,420,48) ENDIF create_gadget(4,21,60,"EXIT",okay2%()) create_gadget(4,346,60,"PREVIOUS",cancel2%()) REPEAT string_gadget(4,190,28,29,80,arexx_command$,dummy%) test_gadget(4,okay2%(),itsokay!) test_gadget(4,cancel2%(),prev!) IF NOT itsokay! THEN IF dummy%=-1 THEN prev!=TRUE ENDIF ' IF prev! THEN ! Cursor Up test_gadget_keypress(4,cancel2%(),prev!) arexx_command$=prev_arexx_command$ string_position%=100 ELSE IF dummy%=1 ! Cursor Down arexx_command$="" ELSE IF dummy%=2 ! Return IF arexx_command$="" THEN itsokay!=TRUE ELSE prev_arexx_command$=arexx_command$ arexx_command(arexx_command$,ret1%,x%,x%) arexx_command$="" ' ' Display the result of the command ' IF ret1%=10 AND result$="" THEN a$="10,Unknown ARexx Command" ELSE IF result$="" THEN a$=STR$(ret1%) ELSE a$=STR$(ret1%)+","+CHAR{V:result$} ENDIF ENDIF ' colour2(4,pen1%,backcol%) text(4,188,46,LEFT$(a$+SPACE$(28),28)) ' ENDIF ENDIF ENDIF UNTIL itsokay! OR buggeroff! OR abortgadget! test_gadget_keypress(4,okay2%(),itsokay!) ENDIF close_window(4) hide_cursor!=TRUE ' arexx_interpreter!=FALSE ' RETURN > PROCEDURE arexx_script ' ' This facility lets the user run an ARexx script file from ' within the editor. The user simply types in the filename ' and the editor will run it. ' open_window(2,130,50,400,200,"Run/Define ARexx Script") IF NOT unable_to_open_window! THEN ' hit$="@RUN" colour2(2,pen1%,backcol%) ' draw_box(2,30,25,487,130) ' heading(2,520,28,"ARexx Script Filenames") FOR clare%=1 TO 10 refresh_string(2,20,10+clare%*14,39,arexx_script$(clare%)) NEXT clare% create_gadget(2,344,1+1*14,hit$,gad1%()) create_gadget(2,344,1+2*14,hit$,gad2%()) create_gadget(2,344,1+3*14,hit$,gad3%()) create_gadget(2,344,1+4*14,hit$,gad4%()) create_gadget(2,344,1+5*14,hit$,gad5%()) create_gadget(2,344,1+6*14,hit$,gad6%()) create_gadget(2,344,1+7*14,hit$,h%()) create_gadget(2,344,1+8*14,hit$,s%()) create_gadget(2,344,1+9*14,hit$,a%()) create_gadget(2,344,1+10*14,hit$,p%()) create_gadget(2,180,177,accept$,okay%()) text(2,50,167,"Map scripts to CTRL+F1..F10 :") casepos%=0 switch!=TRUE REPEAT ' IF switch! THEN show_switch(2,arexx_hotkey!,290,158,r%()) ENDIF ' FOR clare%=1 TO 10 arexx_script$=arexx_script$(clare%) string_group(2,20,10+clare%*14,39,100,clare%-1,casepos%,arexx_script$,dummy%) arexx_script$(clare%)=arexx_script$ NEXT clare% casepos%=(casepos%+dummy%+10) MOD 10 test_gadget(2,gad1%(),okay!) IF okay! THEN clare%=1 ELSE test_gadget(2,gad2%(),okay!) IF okay! THEN clare%=2 ELSE test_gadget(2,gad3%(),okay!) IF okay! THEN clare%=3 ELSE test_gadget(2,gad4%(),okay!) IF okay! THEN clare%=4 ELSE test_gadget(2,gad5%(),okay!) IF okay! THEN clare%=5 ELSE test_gadget(2,gad6%(),okay!) IF okay! THEN clare%=6 ELSE test_gadget(2,h%(),okay!) IF okay! THEN clare%=7 ELSE test_gadget(2,s%(),okay!) IF okay! THEN clare%=8 ELSE test_gadget(2,a%(),okay!) IF okay! THEN clare%=9 ELSE test_gadget(2,p%(),okay!) IF okay! THEN clare%=10 ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF test_gadget(2,r%(),switch!) IF switch! THEN arexx_hotkey!=NOT arexx_hotkey! ENDIF test_gadget(2,okay%(),cancel!) IF dummy%=2 THEN cancel!=TRUE ENDIF UNTIL okay! OR cancel! OR abortgadget! test_gadget_keypress(2,okay%(),cancel!) close_window(2) ' IF okay! THEN IF TRIM$(arexx_script$(clare%))="" THEN inform("ARexx Script Not Defined!") ELSE send_rexx_command(arexx_script$(clare%)) ENDIF ENDIF ENDIF RETURN > PROCEDURE arexx_result(temp$,dummy%) ' ' Sets the global variable RESULTS to the of the input parameter ' r$ iff we are currently in an ARexx command. ' IF arexx_command! THEN result$=temp$ ret1%=dummy% ' ' Convert any "|" characters into a "," ' x%=INSTR(result$,"|") WHILE x%<>0 MID$(result$,x%,1)="," x%=INSTR(result$,"|") WEND ENDIF RETURN > PROCEDURE arexx_command(com$,VAR ret1%,ret2%,result%) ' ' This procedure accepts an ARexx command and will subsequently ' perform it. ' LOCAL count%,pos% ' ' First of all, I will split the entire command up into the actual ' command name and any of its parameters. These are stored in an ' array which acts just like the argv[] array in C. ' count%=0 clare%=1 ' FOR sofie%=0 TO 3 argv$(sofie%)="" NEXT sofie% ' IF INSTR(com$," ")<>0 THEN argv$(3)=RIGHT$(com$,LEN(com$)-INSTR(com$," ")) ENDIF ' WHILE clare%<=LEN(com$) AND count%<=2 a$=MID$(com$,clare%,1) IF a$=CHR$(34) THEN endchar$=CHR$(34) ELSE IF a$="'" endchar$="'" ELSE endchar$=" " argv$(count%)=argv$(count%)+a$ ENDIF clare%=clare%+1 ' REPEAT a$=MID$(com$,clare%,1) IF a$<>endchar$ THEN argv$(count%)=argv$(count%)+a$ ENDIF clare%=clare%+1 UNTIL a$=endchar$ OR clare%>LEN(com$) argv$(count%)=TRIM$(argv$(count%)) count%=count%+1 WEND argv$(0)=UPPER$(argv$(0)) argv$(4)=LEFT$(argv$(1),5) a$=argv$(3) strip_inverted_commas(a$) argv$(3)=a$ on$="ON" ' ' initialise the return parameters which will be used ' to reply to the ARexx script with ' arexx_command!=TRUE result$="" ret1%=0 ret2%=0 ' ' Now that we have argv$() set up, lets detecting some commands :- ' ' ######################### THE AREXX COMMANDS ########################## ' IF argv$(0)="OPENFILE" open_file ELSE IF argv$(0)="FINDFILE" find_file ELSE IF argv$(0)="SAVEFILE" AND curfilename$<>"" @save_file(FALSE) ELSE IF argv$(0)="SAVEFILEAS" @save_as ELSE IF argv$(0)="REVERTFILE" revert ELSE IF argv$(0)="INSERTFILE" insert_file ELSE IF argv$(0)="PRINTFILE" print_document("",docstart%,noofchars%) ELSE IF argv$(0)="ERASEFILE" erase_document ' ' Cursor Movement ' ELSE IF argv$(0)="MOVEUP" FOR clare%=1 TO MIN(MAX(VAL(argv$(4)),1),nooflines%) cursor_up NEXT clare% ELSE IF argv$(0)="MOVEDOWN" FOR clare%=1 TO MIN(MAX(VAL(argv$(4)),1),nooflines%) cursor_down NEXT clare% ELSE IF argv$(0)="MOVELEFT" FOR clare%=1 TO MIN(MAX(VAL(argv$(4)),1),noofchars%) cursor_left NEXT clare% ELSE IF argv$(0)="MOVERIGHT" FOR clare%=1 TO MIN(MAX(VAL(argv$(4)),1),noofchars%) cursor_right NEXT clare% ELSE IF argv$(0)="MOVEPGUP" FOR clare%=1 TO MIN(MAX(VAL(argv$(4)),1),noofchars%) page_up NEXT clare% ELSE IF argv$(0)="MOVEPGDN" FOR clare%=1 TO MIN(MAX(VAL(argv$(4)),1),noofchars%) page_down NEXT clare% ELSE IF argv$(0)="MOVENEXTWORD" FOR clare%=1 TO MIN(MAX(VAL(argv$(4)),1),noofchars%) next_word NEXT clare% ELSE IF argv$(0)="MOVEPREVWORD" FOR clare%=1 TO MIN(MAX(VAL(argv$(4)),1),noofchars%) prev_word NEXT clare% ELSE IF argv$(0)="MOVEBOF" cursor_bof ELSE IF argv$(0)="MOVEEOF" cursor_eof ELSE IF argv$(0)="MOVEBOL" cursor_bol ELSE IF argv$(0)="MOVEEOL" cursor_eol ' ' Block Operations ' ELSE IF argv$(0)="BLOCKSTART" start_of_block(lineadd%,0) ELSE IF argv$(0)="BLOCKEND" end_of_block(lineadd%,0) ELSE IF argv$(0)="VERTBLOCKSTART" vert_block_start ELSE IF argv$(0)="VERTBLOCKEND" vert_block_end ELSE IF argv$(0)="BLOCKOFF" block_off ELSE IF argv$(0)="CUTBLOCK" cut_block ELSE IF argv$(0)="COPYBLOCK" copy_block block_off ELSE IF argv$(0)="INSERTCLIP" insert_block ELSE IF argv$(0)="ERASEBLOCK" erase_block ELSE IF argv$(0)="PRINTCLIP" AND blockcopied! print_document("",clipstart%,clipsize%) ELSE IF argv$(0)="SORTCLIP" sort ELSE IF argv$(0)="WRITECLIP" write_block ' ' Editting Operations ' ELSE IF argv$(0)="CENTRELINE" centre_line ELSE IF argv$(0)="DELETELINE" del_line ELSE IF argv$(0)="UNDELETELINE" undo_line ELSE IF argv$(0)="DELETETOEOLN" del_to_eoln ELSE IF argv$(0)="DELETETOBOLN" del_to_boln ELSE IF argv$(0)="DELETEWORD" del_word ELSE IF argv$(0)="STRIPEOLN" strip_eol_blanks(TRUE) get_curpos cursor_on ELSE IF argv$(0)="UPPERWORD" upperword ELSE IF argv$(0)="LOWERWORD" lowerword ELSE IF argv$(0)="TOGGLECURSORMODE" toggle_mode ' ' Miscellaneuos ' ELSE IF argv$(0)="QUIT" buggeroff!=TRUE ELSE IF argv$(0)="HELP" inform("Try Using EdWordHelp!") ELSE IF argv$(0)="ICONIFY" iconify ELSE IF argv$(0)="ABOUT" about ELSE IF argv$(0)="ZOOM" zoom(TRUE) ELSE IF argv$(0)="EDITORTOFRONT" IF use_wbench! THEN ~WindowToFront(winptr%(0)) ELSE ~ScreenToFront(scrptr%(1)) ENDIF ELSE IF argv$(0)="EDITORTOBACK" IF use_wbench! THEN ~WindowToBack(winptr%(0)) ELSE ~ScreenToBack(scrptr%(1)) ENDIF ELSE IF argv$(0)="WINSIZE" IF arexx_interpreter! THEN arexx_result("ARexx Script Only",10) ELSE IF argv$(2)="" THEN arexx_result("WinSize YCoord Height",10) ELSE new_screen_mode ENDIF ENDIF ELSE IF argv$(0)="AUTOINDENT" autoindent!=(UPPER$(argv$(1))=on$) ELSE IF argv$(0)="STOPATEOL" eol_overflow!=(UPPER$(argv$(1))<>on$) ELSE IF argv$(0)="WORDWRAP" word_wrap!=(UPPER$(argv$(1))=on$) ELSE IF argv$(0)="WORDWRAPCUTOFF" word_wrap_cutoff%=MAX(MIN(VAL(argv$(4)),999),10) ELSE IF argv$(0)="TABS2SPACE" convert_tab2space ELSE IF argv$(0)="TABSIZE" set_tab_size ELSE IF argv$(0)="STRIPCODES" strip_chars ELSE IF argv$(0)="LOADPREFS" IF arexx_interpreter! THEN arexx_result("ARexx Script Only",10) ELSE preferences ENDIF ELSE IF argv$(0)="INFORM" arexx_command!=FALSE inform(argv$(3)) ELSE IF argv$(0)="REQUEST" arexx_command!=FALSE request(argv$(3),accept$,cancel$,ret1%) ELSE IF argv$(0)="MESSAGE" message(argv$(3)) ELSE IF argv$(0)="SETVIEW" IF arexx_interpreter! THEN arexx_result("ARexx Script Only",10) ELSE IF (UPPER$(argv$(1))="OFF") THEN cursor_off supress_view!=TRUE set_pointer(1) ELSE refresh_view set_pointer(0) ENDIF ENDIF ELSE IF argv$(0)="GETLINE" kim1%=lineadd% kim2%=kim1% next_line(kim2%) kim2%=kim2%-1 IF kim2%-kim1%=0 THEN result$="" ELSE result$=SPACE$(kim2%-kim1%) BMOVE kim1%,V:result$,LEN(result$) ENDIF ELSE IF argv$(0)="GETLINENUMB" arexx_result(STR$(curline%),0) ELSE IF argv$(0)="GETDOCNUMB" arexx_result(STR$(curr_docno%+1),0) ELSE IF argv$(0)="GETNOOFDOCS" arexx_result(STR$(noofdocs%),0) ELSE IF argv$(0)="GETFILENAME" arexx_result(curfilename$,0) ELSE IF argv$(0)="GETCHAR" arexx_result(CHR$(PEEK(curradd%)),0) ELSE IF argv$(0)="ISSELECTED" IF blockon! AND (NOT vertblock!) THEN arexx_result("-1",0) ELSE arexx_result("0",0) ENDIF ELSE IF argv$(0)="ISEOF" update_cur_char clare!=(a$="EOF") arexx_result(STR$(clare!),clare!) ELSE IF argv$(0)="ISEOL" clare!=(PEEK(curradd%)=lf%) arexx_result(STR$(clare!),clare!) ELSE IF argv$(0)="ISINBLOCK" IF blockon! AND (NOT vertblock!) THEN IF lineadd%>=blockstart% AND lineadd%3 THEN arexx_result("UserCommand <1..3> only",10) ELSE execute(VAL(argv$(4))) ENDIF ' ' Search Routines ' ELSE IF argv$(0)="JUMPTOLINE" jump_to_line ELSE IF argv$(0)="FINDTEXT" find ELSE IF argv$(0)="FINDNEXT" find_next ELSE IF argv$(0)="FINDPREVIOUS" find_previous ELSE IF argv$(0)="FINDREPLACE" find_replace ELSE IF argv$(0)="FINDHEX" find_hex ELSE IF argv$(0)="JUMPTOBLOCK" IF blockon! AND (NOT vertblock!) THEN argv$(1)=STR$(start_block_line%) jump_to_line ELSE arexx_result("No Block Defined",5) ENDIF ELSE IF argv$(0)="CASEDEPEND" casedep!=(UPPER$(argv$(1))=on$) ELSE IF argv$(0)="SEARCHZOOM" searchzoom!=(UPPER$(argv$(1))=on$) ELSE IF argv$(0)="GOTOBYTEOFFSET" goto_offset ELSE IF argv$(0)="MATCHBRACKETS" match_brackets ELSE IF argv$(0)="SETMARK" set_mark(MIN(MAX(VAL(argv$(4)),1),3)) ELSE IF argv$(0)="JUMPTOMARK" jump_to_mark(MIN(MAX(VAL(argv$(4)),1),3)) ' ' Text Casing Routines ' ELSE IF argv$(0)="LOADKEYWORDS" keyfile$=argv$(3) @load_keywords(FALSE) IF diskerror! THEN arexx_result("Keyword File Not Found!",10) ENDIF ELSE IF argv$(0)="KEYWORDCASE" keywordcase%=MIN(MAX(VAL(argv$(4)),0),4) defaultkeycase%=keywordcase% update_case_flag ELSE IF argv$(0)="VARIABLECASE" variablecase%=MIN(MAX(VAL(argv$(4)),0),3) ELSE IF argv$(0)="SETCASE" manual_global_case ELSE IF argv$(0)="TEXTCASING" newcasing!=(UPPER$(argv$(1))=on$) IF newcasing!=(keywordcase%=0) THEN toggle_cas ENDIF ' ' Macro commands ' ELSE IF argv$(0)="STARTMACRO" start_macro ELSE IF argv$(0)="STOPMACRO" stop_macro ELSE IF argv$(0)="PLAYBACKMACRO" playback_macro ELSE IF argv$(0)="REPEATMACRO" repeat_macro ELSE IF argv$(0)="LOADMACRO" IF INSTR(argv$(3),":")=0 AND INSTR(argv$(3),"/")=0 THEN argv$(3)=macro_path$+argv$(3) ENDIF @load_a_macro ELSE IF argv$(0)="CLEARMACRO" clear_macro ' ' Document Modification ' ELSE IF argv$(0)="NEXTDOC" next_doc ret1%=0 ELSE IF argv$(0)="PREVIOUSDOC" prev_doc ret1%=0 ELSE IF argv$(0)="CREATEDOC" create_doc ret1%=0 ELSE IF argv$(0)="DELETEDOC" @remove_doc ret1%=0 ELSE IF argv$(0)="SELECTDOC" backup_curr_doc activate_doc(MIN(MAX(VAL(argv$(4))-1,0),noofdocs%-1)) refresh_multidocs ELSE IF argv$(0)="INSERTASCII" insert_ascii ELSE IF argv$(0)="INSERTTEXT" FOR clare%=1 TO LEN(argv$(3)) text2document(MID$(argv$(3),clare%,1)) NEXT clare% ELSE IF argv$(0)="UNDO" undo_option ELSE IF argv$(0)="LINEFEED" FOR clare%=1 TO MIN(MAX(VAL(argv$(4)),1),&HFFFF) line_feed NEXT clare% ELSE IF argv$(0)="DELETECHAR" FOR clare%=1 TO MIN(MAX(VAL(argv$(4)),1),noofchars%) del_char NEXT clare% ELSE IF argv$(0)="BACKSPACECHAR" FOR clare%=1 TO MIN(MAX(VAL(argv$(4)),1),noofchars%) back_space_char NEXT clare% ELSE ' ' Result1=10 if the command wasn't recognised ' ret1%=10 ENDIF ' ' the string RESULT$ contains the result of our ' command which we wish to return to the ARexx ' script. ' IF result$="" THEN result%=0 ELSE result$=result$+CHR$(0) result%=V:result$ ENDIF ' IF NOT buggeroff! THEN arexx_command!=FALSE ENDIF ' RETURN ' ************************** MACRO THINGYMABOBS ***************************** > PROCEDURE start_macro ' ' Starts recording a macro ' IF (NOT recording_macro!) AND (NOT playing_macro!) THEN noofmacros%=0 ' IF macromemory%<>0 THEN ~FreeMem(macromemory%,maxmacros%*macrosize%) ENDIF ' macromemory%=AllocMem(maxmacros%*macrosize%,1) IF macromemory%=0 THEN inform("Sorry, Cannot Record Macros!|Not Enough Memory Available.") ELSE recording_macro!=TRUE menu_attr(7,1,menuoff%) ! Start Macro menu_attr(7,3,menuoff%) ! Playback Macro menu_attr(7,4,menuoff%) ! Repeat Macro menu_attr(7,6,menuoff%) ! Load Macro menu_attr(7,7,menuoff%) ! Save Macro menu_attr(7,8,menuoff%) ! Clear Macro message("") ENDIF ' ENDIF RETURN > PROCEDURE stop_macro ' ' Stops recording a macro ' IF (recording_macro!) AND (NOT playing_macro!) THEN recording_macro!=FALSE noofmacros%=MAX(0,noofmacros%-1) ' menu_attr(7,1,menuon%) ! Start Macro menu_attr(7,3,menuon%) ! Playback Macro menu_attr(7,4,menuon%) ! Repeat Macro menu_attr(7,6,menuon%) ! Load Macro menu_attr(7,7,menuon%) ! Save Macro menu_attr(7,8,menuon%) ! Clear Macro ' message("") ENDIF RETURN > PROCEDURE record_event ' ' records a input event in the macro list for future playback ' LOCAL mem% ' IF recording_macro! THEN IF noofmacros%>=maxmacros% THEN stop_macro ! switch recording off inform("Macro Limit Exceeded!|Only "+STR$(maxmacros%)+" events can be recorded.") ELSE IF event_class%<>0 AND event_class%<>&H400000 mem%=macromemory%+noofmacros%*macrosize% LPOKE mem%,event_class% DPOKE mem%+4,event_code% DPOKE mem%+6,event_qualifier% LPOKE mem%+8,event_iaddress% DPOKE mem%+12,event_x% DPOKE mem%+14,event_y% noofmacros%=noofmacros%+1 ENDIF playing_macro!=FALSE ENDIF RETURN > PROCEDURE playback_macro ' ' Plays back a macro which has been previously recorded ' IF (NOT recording_macro!) AND (NOT playing_macro!) THEN IF macromemory%=0 THEN no_macro ELSE macrocount%=0 macrorepeat%=1 playing_macro!=TRUE message("Playing Macro...") set_pointer(1) ENDIF ENDIF RETURN > PROCEDURE playback_event ' ' Substitutes an event from the macro list in place of an input event ' LOCAL mem% ' IF playing_macro! THEN ' ' The user can press ESC to abort execution of the macro ' IF event_class%=&H400 AND event_code%=&H45 THEN macrocount%=0 macrorepeat%=0 playing_macro!=FALSE set_pointer(0) inform("Macro Execution Aborted!") ENDIF ' ' See if we are at the end of the macro list ' IF macrocount%>noofmacros% THEN macrocount%=0 macrorepeat%=macrorepeat%-1 ENDIF ' ' Do we have to repeat the macro list again !!??? .... ' IF macrorepeat%<1 THEN playing_macro!=FALSE set_pointer(0) message("") ELSE mem%=macromemory%+macrocount%*macrosize% event_class%=LPEEK(mem%) event_code%=DPEEK(mem%+4) event_qualifier%=DPEEK(mem%+6) event_iaddress%=LPEEK(mem%+8) event_x%=DPEEK(mem%+12) event_y%=DPEEK(mem%+14) macrocount%=macrocount%+1 ENDIF ' ENDIF RETURN > PROCEDURE repeat_macro ' ' Plays back a macro a user-specified number of times ' IF (NOT recording_macro!) AND (NOT playing_macro!) THEN IF macromemory%=0 THEN inform("No Macro Has Been Defined Yet!|Please Select Record Macro First.") ELSE ' macrocount%=0 macrorepeat%=1 IF arexx_command! THEN macrorepeat%=MAX(VAL(argv$(4)),0) ELSE get_line_number("Repeat Macro",320,"How Many Times To Repeat Macro?",macrorepeat%) ENDIF macrorepeat%=MIN(macrorepeat%,999) ' IF macrorepeat%>0 THEN playing_macro!=TRUE message("Playing Macro...") set_pointer(1) ENDIF ' ENDIF ENDIF RETURN > PROCEDURE load_macro ' ' Macro definition loaded in from the end of an EdWord.config file ' IF prefpos%0 THEN BMOVE prefpos%,macromemory%,noofmacros%*macrosize% ENDIF ENDIF ' RETURN > PROCEDURE save_macro ' ' Current macro saved to end of EdWord.config ' IF macromemory%<>0 THEN ~Write(preflock%,macromemory%,noofmacros%*macrosize%) ENDIF RETURN > PROCEDURE load_a_macro ' ' ' IF (NOT recording_macro!) AND (NOT playing_macro!) THEN error!=TRUE newdir!(2)=TRUE path$(2)=macro_path$ get_file(2,"Load A Macro","RUN",status%) IF status%<>0 THEN ' a$=filename$+CHR$(0) lock%=Open(V:a$,mode_old%) IF lock%<>0 THEN ' OPEN "I",#1,a$ size%=LOF(#1)-8 CLOSE #1 ' a$=SPACE$(8) ~Read(lock%,V:a$,8) IF a$<>"EdMacro"+CHR$(10) THEN inform("Error During Operation!|File Is Not A Macro File") ELSE ' IF macromemory%<>0 THEN ~FreeMem(macromemory%,maxmacros%*macrosize%) ENDIF noofmacros%=size% DIV macrosize% macromemory%=AllocMem(maxmacros%*macrosize%,1) IF macromemory%<>0 THEN ~Read(lock%,macromemory%,size%) error!=FALSE ENDIF ' ENDIF ' ~Close(lock%) ELSE inform("Error During Operation!|Macro File Not Found.") ENDIF ' ENDIF macro_path$=path$(2) ' IF NOT error! THEN playback_macro ENDIF ' ENDIF RETURN > PROCEDURE save_a_macro ' ' ' INLINE macroheader%,8 ' IF (NOT recording_macro!) AND (NOT playing_macro!) THEN IF macromemory%<>0 THEN newdir!(2)=TRUE path$(2)=macro_path$ get_file(2,"Save Current Macro","SAVE",status%) IF status%<>0 THEN ' replace_requester(filename$,replace!) IF replace! THEN error!=TRUE a$=filename$+CHR$(0) lock%=Open(V:a$,mode_new%) IF lock%<>0 THEN stats%=Write(lock%,macroheader%,8) IF stats%<>0 THEN stats%=Write(lock%,macromemory%,noofmacros%*macrosize%) ENDIF ~Close(lock%) error!=(stats%=0) ENDIF ' IF error! THEN inform("Error During Operation!|Macro File Not Saved.") ENDIF ' ENDIF macro_path$=path$(2) ENDIF ELSE no_macro ENDIF ENDIF RETURN > PROCEDURE no_macro inform("No Macro Has Been Defined Yet!|Please Select Start/Load Macro First.") RETURN > PROCEDURE clear_macro ' ' Clear the current macro definition ' IF (NOT recording_macro!) AND (NOT playing_macro!) THEN IF macromemory%<>0 THEN ~FreeMem(macromemory%,maxmacros%*macrosize%) noofmacros%=0 macromemory%=0 alert("Current Macro Definition Cleared") ELSE alert("No Macro Currently Defined!") ENDIF ENDIF RETURN ' *********************** CURSOR MOVEMENT ROUTINES ************************** > PROCEDURE scroll_up ' ' The routine to scroll a page up one line and refresh the bottom line. ' The area of the page to be scrolled up depends upon the current ' screen resolution (maxrow) and also whether on the workbench screen. ' This is used by many routines such as CursorDown, LineFeed etc. ' cursory%=maxrow%-1 next_line(topadd%) IF NOT supress_view! THEN scroll(0,8,0,text_offset%,maxcol%*8,maxrow%*8-1+text_offset%) refresh_curr_line update_prop ENDIF RETURN > PROCEDURE scroll_down ' ' The routine to scroll a page down one line and refresh the top line. ' The area of the page to be scrolled up depends upon the current ' screen resolution (maxrow) and also whether on the workbench screen. ' This is used by such procedures as CursorUp etc. ' cursory%=0 prev_line(topadd%) IF NOT supress_view! THEN scroll(0,-8,0,text_offset%,maxcol%*8,maxrow%*8-1+text_offset%) refresh_curr_line update_prop ENDIF RETURN > PROCEDURE scroll_part_up(line%) ' ' Used by operations such as BACKSPACE and DELLINE which only scroll ' part of the screen up. I decided to use ScrollRaster() because a ' simple refresh from the current line was noticably slow. ' IF curline%-cursory%+maxrow% PROCEDURE cursor_right ' ' Moves the cursor one character to the right. If at the end of line, ' then control is passed to the CursorEOL procedure (this is done to ' refresh the cursor position mainly - as it may be floating anywhere ' after the line feed). Any screen refreshes necessary are performed ' and the status bar is updated to the new coordinates ' IF PEEK(curradd%)=lf% THEN IF (eol_overflow!) AND (curline%maxrow%-1 scroll_up ENDIF cursor_on update_line update_column make_undo_string ELSE cursor_eol ENDIF ELSE cursor_off curradd%=curradd%+1 get_cursorx IF refresh! THEN refresh_page ENDIF ENDIF cursor_on update_column RETURN > PROCEDURE cursor_left ' ' Moves the cursor one character to the left, if it is not already at ' the far left edge. Any necessary page refreshes are performed and the ' status bar is updated accordingly ' IF cursorx%+indent%<=0 THEN IF curline%>1 AND eol_overflow! THEN cursor_off set_case_if_changed curline%=curline%-1 cursory%=cursory%-1 curradd%=lineadd%-1 prev_line(lineadd%) get_cursorx IF refresh! THEN refresh_page_nocursor ENDIF IF cursory%<0 THEN scroll_down ENDIF cursor_on update_line make_undo_string ENDIF ELSE cursor_off IF curradd%>lineadd% curradd%=curradd%-1 ENDIF get_cursorx IF refresh! THEN refresh_page ENDIF cursor_on update_column ENDIF RETURN > PROCEDURE cursor_down ' ' Moves the cursor down to the same x-coord on the next line (assuming that ' it is not over the last line). If it goes off the bottom of the screen ' then the page is scrolled up. The status bar is also updated appropriately ' IF curline%maxrow%-1 THEN scroll_up ENDIF cursor_on update_line make_undo_string ENDIF RETURN > PROCEDURE cursor_up ' ' Moves the cursor up to the same x-coord on the line above (assuming that ' it is not already on line no.1). If it goes off the top of the screen, ' then the page is scrolled down accordingly. ' IF curline%>1 THEN cursor_off set_case_if_changed curline%=curline%-1 cursory%=cursory%-1 prev_line(lineadd%) get_curpos IF cursory%<0 THEN scroll_down ENDIF cursor_on update_line make_undo_string ENDIF RETURN > PROCEDURE cursor_eol ' ' Moves the cursor to the End of the current line. It will perform any page ' refreshes that are necessary. It will also snap the cursor back to the ' End Of Line if the address pointer is over the EOL but the cursor is off ' floating somewhere else - this is possible when the cursor is moved down ' onto a line after the EOL. ' cursor_off oldindent%=indent% WHILE PEEK(curradd%)<>lf% curradd%=curradd%+1 WEND get_cursorx ' IF oldindent%<>indent% THEN refresh_page ELSE cursor_on ENDIF update_column RETURN > PROCEDURE cursor_bol ' ' Moves the cursor to the beginning of the current line - making any required ' page refreshes while it goes - Who the fuck invented documentation !!!! ' I'm completely bored shitless !!!! And nobody is every going to read this ' crap anyway are they. ' If they are, then I apologise for my French - but why the fuck are you ' reading this for, when you could be out for a run or down the gym. Yeah, ' this is a bit easier and less tiring isn't it - If you think so, then ' you try to write a mean muthering bastard like this !!! Well, can't stay ' in this procedure all day you know - loads of things to do I'm afraid ' Catch you later ...... Marty. ' cursor_off curradd%=lineadd% cursorx%=0 lineoverflow!=FALSE IF indent%>0 THEN indent%=0 refresh_page ELSE cursor_on ENDIF update_column RETURN > PROCEDURE cursor_bof ' ' Surprise, Sur-fucking-prise, this little beauty moves the cursor, not ' to mars, not to the third vortex of another time zone, and (unfortunately) ' not to the nearest Pizzaland for a chicken & sweetcorn pizza - it does ' however move it the Beginning Of the File - oh yeah! BOF - simple ' really init ! ' IF curradd%>docstart% THEN cursor_off set_case_if_changed curline%=1 curradd%=docstart% lineadd%=docstart% cursorx%=0 cursory%=0 IF topadd%>docstart% OR indent%>0 THEN topadd%=docstart% indent%=0 refresh_page ENDIF update_prop update_line update_column cursor_on make_undo_string ENDIF RETURN > PROCEDURE cursor_eof ' ' Take a wild fucking guess !! ' IF curline%<>nooflines% OR cursorx%+indent%>0 OR curradd%>docstart%+noofchars% THEN IF curradd%<=docstart%+noofchars% THEN cursor_off set_case_if_changed ENDIF topline%=curline%-cursory% curline%=nooflines% lineadd%=docstart%+noofchars% prev_line(lineadd%) curradd%=lineadd% cursorx%=0 IF nooflines%<=maxrow% OR topline%>=nooflines%-maxrow%+1 THEN cursory%=nooflines%-topline% IF indent%>0 THEN indent%=0 refresh_page ENDIF ELSE cursory%=maxrow%-1 topadd%=lineadd% FOR l%=1 TO maxrow%-1 prev_line(topadd%) NEXT l% indent%=0 refresh_page ENDIF update_prop update_line update_column cursor_on make_undo_string ENDIF RETURN > PROCEDURE cursor_top_of_screen ' ' Moves the cursor up to the same x-coord on the line at the ' top of the screen. ' IF cursory%>0 THEN cursor_off set_case_if_changed REPEAT curline%=curline%-1 cursory%=cursory%-1 prev_line(lineadd%) UNTIL cursory%=0 get_curpos cursor_on update_line make_undo_string ELSE page_up ENDIF RETURN > PROCEDURE cursor_bottom_of_screen ' ' Moves the cursor down to the same x-coord on the line ' at the bottom of the screen ' IF cursory%nooflines% THEN cursor_off set_case_if_changed REPEAT curline%=curline%+1 cursory%=cursory%+1 next_line(lineadd%) UNTIL cursory%=maxrow%-1 OR curline%=nooflines% get_curpos cursor_on update_line make_undo_string ELSE page_down ENDIF RETURN > PROCEDURE cursor_far_left ' ' Repositions the cursor at the left most edge of the screen ' IF cursorx%>0 THEN cursor_off cursorx%=0 get_curpos cursor_on update_column ELSE cursor_left IF cursorx%>0 THEN cursor_far_left ENDIF ENDIF RETURN > PROCEDURE cursor_far_right ' ' Repositions the cursor at the right most edge of the screen ' IF cursorx%lf% cursor_right IF cursorx% PROCEDURE page_down ' ' MARTIN WOZ ERE 2/9/91 <==-- a little bit of in program grafitti ' set_case_if_changed IF nooflines%>maxrow% AND curline%-cursory%<=nooflines%-maxrow% THEN jump%=maxrow%-2 WHILE curline%-cursory%+jump%+(maxrow%-1)>nooflines% jump%=jump%-1 WEND FOR l%=1 TO jump% next_line(topadd%) next_line(lineadd%) NEXT l% curline%=curline%+jump% get_curpos update_prop update_line update_column refresh_page make_undo_string ELSE cursor_eof ENDIF RETURN > PROCEDURE page_up ' ' Q. What is brown and sticky ???? ' ' A. A stick! (or should that be `sick') ' set_case_if_changed IF topadd%>docstart% THEN jump%=maxrow%-2 WHILE curline%-cursory%-jump%<1 jump%=jump%-1 WEND FOR l%=1 TO jump% prev_line(topadd%) prev_line(lineadd%) NEXT l% curline%=curline%-jump% get_curpos update_prop update_line update_column refresh_page make_undo_string ELSE cursor_bof ENDIF RETURN > PROCEDURE next_word ' ' Q. What's orange and sounds like a parrot ??? ' ' A. A carrot !!! - laugh, or I'll guru now !!! ' IF NOT eol_overflow! THEN IF PEEK(curradd%)=lf% THEN cursor_eol ELSE cursor_off REPEAT curradd%=curradd%+1 UNTIL ((PEEK(curradd%-1)<48 OR PEEK(curradd%-1)>122) AND (PEEK(curradd%)>=48 AND PEEK(curradd%)<123)) OR PEEK(curradd%)=lf% get_cursorx IF refresh! THEN refresh_page ENDIF cursor_on update_column ENDIF ELSE IF NOT (PEEK(curradd%)=lf% AND curline%=nooflines%) THEN cursor_off free_abyss force_refresh%=0 REPEAT IF PEEK(curradd%)=lf% THEN force_refresh%=force_refresh%+1 IF force_refresh%=1 THEN set_case_if_changed ENDIF ENDIF curradd%=curradd%+1 UNTIL ((PEEK(curradd%-1)<48 OR PEEK(curradd%-1)>122) AND (PEEK(curradd%)>=48 AND PEEK(curradd%)<123)) OR (PEEK(curradd%)=lf% AND curradd%>=docstart%+noofchars%-1) IF force_refresh%>0 THEN FOR jody%=1 TO force_refresh% curline%=curline%+1 cursory%=cursory%+1 next_line(lineadd%) IF cursory%>maxrow%-1 THEN scroll_up ENDIF NEXT jody% get_cursorx ELSE get_cursorx IF refresh! THEN refresh_page ENDIF ENDIF update_line cursor_on update_column ENDIF ENDIF RETURN > PROCEDURE prev_word ' ' You sort of get the impression that I'm not putting my every effort into ' this documentation lark don't you. I wonder what my old first-year ' pascal lecturers would have to say about my program documentation ? ' Well they're not here now are they - so I'll do what I soapy well feel like! ' IF NOT eol_overflow! THEN IF cursorx%+indent%>0 THEN cursor_off IF curradd%>lineadd% REPEAT curradd%=curradd%-1 UNTIL ((PEEK(curradd%)>=48 AND PEEK(curradd%)<123) AND (PEEK(curradd%-1)<48 OR PEEK(curradd%-1)>122)) OR curradd%=lineadd% ENDIF get_cursorx IF refresh! THEN refresh_page ENDIF cursor_on update_column ENDIF ELSE IF curradd%>docstart% THEN cursor_off free_abyss force_refresh%=0 REPEAT IF PEEK(curradd%-1)=lf% THEN force_refresh%=force_refresh%+1 IF force_refresh%=1 THEN set_case_if_changed ENDIF ENDIF curradd%=curradd%-1 UNTIL ((PEEK(curradd%)>=48 AND PEEK(curradd%)<123) AND (PEEK(curradd%-1)<48 OR PEEK(curradd%-1)>122)) OR curradd%=docstart% IF force_refresh%>0 THEN FOR jody%=1 TO force_refresh% curline%=curline%-1 cursory%=cursory%-1 prev_line(lineadd%) IF cursory%<0 THEN scroll_down ENDIF NEXT jody% get_cursorx ELSE get_cursorx IF refresh! THEN refresh_page ENDIF ENDIF update_line cursor_on update_column ENDIF ENDIF RETURN > PROCEDURE prev_line(VAR address%) ' ' Points ADDRESS at the start of the previous line of text in memory ' IF address%>docstart% THEN reg%(8)=V:address% ! A0 = Address reg%(9)=V:docstart% ! A1 = DocStart RCALL mc68000prevline%,reg%() ELSE address%=docstart% ENDIF RETURN > PROCEDURE next_line(VAR address%) ' ' Points ADDRESS at the start of the next line of text in memory ' reg%(8)=V:address% ! A0=address RCALL mc68000nextline%,reg%() RETURN > PROCEDURE move_up_one_line IF topadd%>docstart% THEN IF cursory%>0 THEN position_cursor(INT(x%/8),0,TRUE) ENDIF prev_line(lineadd%) scroll_down curline%=curline%-1 ENDIF RETURN > PROCEDURE move_down_one_line IF curline%-cursory%+maxrow%<=nooflines% THEN IF cursory% PROCEDURE count_lines(docstart%,noofchars%,VAR nooflines%) ' ' Counts the number of lines in the range DOCSTART to DOCSTART+NOOFCHARS-1 ' and returns this value into NOOFLINES ' clear_registers reg%(8)=V:docstart% reg%(9)=V:noofchars% reg%(10)=V:nooflines% RCALL mc68000countlines%,reg%() RETURN > PROCEDURE centre_line ' ' This function will centre the line which the cursor is on so that it ' appears in the centre of the screen. An error message is displayed if ' the line is too long to be centred on one screen. No action is taken ' if the line is already centred on the screen. ' LOCAL before$,after$ ' convert_line(lineadd%,1,before$) convert_line(lineadd%,0,after$) after$=TRIM$(after$) IF after$<>"" THEN IF LEN(after$)before$ THEN free_abyss replace(lineadd%,before$,after$) get_curpos refresh_curr_line cursor_on ENDIF ELSE alert("Line is too long to be centred onto one screen!") ENDIF ENDIF RETURN > PROCEDURE del_line IF curline%lf% THEN free_abyss tempstart%=lineadd% tempend%=lineadd% next_line(tempend%) ' IF linebuffer%<>0 THEN ~FreeMem(linebuffer%,linebuffersize%) ENDIF ' linebuffersize%=tempend%-tempstart% linebuffer%=AllocMem(linebuffersize%,1) IF linebuffer%<>0 THEN cursor_off FOR l%=0 TO linebuffersize%-1 POKE linebuffer%+l%,PEEK(lineadd%+l%) NEXT l% update_block_delete(1,linebuffersize%) ' BMOVE lineadd%+linebuffersize%,lineadd%,docstart%+noofchars%-lineadd%+1 ' noofchars%=noofchars%-linebuffersize% ' IF curline%=nooflines% THEN curradd%=lineadd% insert_char_nodisplay(CHR$(lf%)) IF indent%>0 THEN indent%=0 refresh_page ENDIF cursorx%=0 ELSE nooflines%=nooflines%-1 scroll_part_up(cursory%) move_marks(-1) ENDIF refresh_curr_line get_curpos update_column update_prop make_undo_string lineupdated!=TRUE cursor_on ELSE inform("Cannot Allocate Enough Memory|For The Deleted Line!") ENDIF ELSE IF cursorx%+indent%>0 THEN cursor_off cursorx%=0 IF indent%>0 THEN indent%=0 refresh_page ENDIF cursor_on update_column ENDIF ENDIF RETURN > PROCEDURE del_to_eoln LOCAL endofline%,deletesize% ' free_abyss endofline%=lineadd% next_line(endofline%) endofline%=endofline%-1 ' deletesize%=endofline%-curradd% IF deletesize%>0 THEN cursor_off BMOVE curradd%+deletesize%,curradd%,docstart%+noofchars%-curradd%+1 ' update_block_delete_char(0,deletesize%) noofchars%=noofchars%-deletesize% refresh_curr_line update_column cursor_on lineupdated!=TRUE ENDIF RETURN > PROCEDURE del_to_boln LOCAL endofline%,deletesize% ' IF curradd%>lineadd% THEN free_abyss ' endofline%=lineadd% next_line(endofline%) endofline%=endofline%-1 ' deletesize%=curradd%-lineadd% IF deletesize%>0 THEN cursor_off BMOVE curradd%,lineadd%,docstart%+noofchars%-curradd%+3 ' update_block_delete_char(0,deletesize%) noofchars%=noofchars%-deletesize% curradd%=lineadd% cursorx%=0 ' IF indent%>0 THEN indent%=0 refresh_page ELSE refresh_curr_line cursor_on ENDIF update_column lineupdated!=TRUE ENDIF ENDIF RETURN > PROCEDURE del_word LOCAL startadd%,length%,at_eoln! a$=CHR$(PEEK(curradd%)) IF a$>" " THEN startadd%=curradd% length%=1 a%=PEEK(startadd%-1) WHILE a%>32 AND a%<>10 AND startadd%>docstart% startadd%=startadd%-1 a%=PEEK(startadd%-1) WEND ' a%=PEEK(startadd%+length%) WHILE a%>32 AND a%<>10 length%=length%+1 a%=PEEK(startadd%+length%) WEND ' WHILE a%=32 OR a%=tab% length%=length%+1 a%=PEEK(startadd%+length%) WEND ' BMOVE startadd%+length%,startadd%,docstart%+noofchars%+abyss%-startadd%+1 abyssend%=abyssend%-length% ' noofchars%=noofchars%-length% curradd%=startadd% get_cursorx update_column refresh_curr_line cursor_on docupdated!=TRUE ENDIF RETURN > PROCEDURE strip_eol_blanks(strip!) ' ' Strips any tabs or spaces from the end of a line of text. ' This is the routine which implements the Strip EOL facility. ' IF strip! THEN ' ' Get a string containing the current line of text ' convert_line(lineadd%,1,curline$) IF curline$<>"" THEN stripline$=curline$ strip_eol(stripline$) IF LEN(stripline$)<>LEN(curline$) THEN replace(lineadd%,curline$,stripline$) end_of_line%=lineadd%+LEN(stripline$) IF curradd%>end_of_line% THEN curradd%=end_of_line% ENDIF refresh_curr_line ENDIF ENDIF ENDIF RETURN > PROCEDURE undo_line IF linebuffer%>0 THEN IF noofchars%+linebuffersize%+memlow%>memorysize% THEN memory_alert ELSE cursor_off free_abyss BMOVE lineadd%,lineadd%+linebuffersize%,docstart%+noofchars%-lineadd% ' FOR l%=0 TO linebuffersize%-1 POKE lineadd%+l%,PEEK(linebuffer%+l%) NEXT l% update_block_insert(1,linebuffersize%) ' nooflines%=nooflines%+1 noofchars%=noofchars%+linebuffersize% get_curpos scroll(0,-8,0,cursory%*8+text_offset%,maxcol%*8,maxrow%*8-1+text_offset%) refresh_curr_line update_prop update_column cursor_on make_undo_string move_marks(1) lineupdated!=TRUE ENDIF ENDIF RETURN > PROCEDURE get_autoindent_string(VAR text$) ' ' Gets a string containing all of the leading spaces and tabs ' which are at the start of the current line. This string will ' be used to indent the next line when the autoindent feature ' is on. ' text$="" IF autoindent! THEN tempadd%=lineadd% WHILE (PEEK(tempadd%)=32 OR PEEK(tempadd%)=tab%) AND tempadd% PROCEDURE indent_line(indent$) ' ' Adds the number of space/tab characters to the start of a line which ' are contained with the parameter string INDENT$. This string will have ' been made up by the Get_AutoIndent_String() procedure above. This ' accomplishes the Auto Indenting feature. ' IF autoindent! THEN FOR clare%=1 TO LEN(indent$) insert_char_nodisplay(MID$(indent$,clare%,1)) NEXT clare% ENDIF RETURN > PROCEDURE make_undo_string ' ' Creates a null-terminated buffer containing the current line of text. ' Used to save the contents of each line before editting so that it is ' possible to undo any changes. ' clear_registers reg%(10)=V:undobuffer% reg%(11)=V:undosize% reg%(12)=V:lineadd% RCALL mc68000makestring%,reg%() IF lineupdated! THEN docupdated!=TRUE lineupdated!=FALSE ENDIF RETURN > PROCEDURE undo_option LOCAL endline%,linesize% IF undobuffer%<>0 THEN free_abyss ' endline%=lineadd% next_line(endline%) linesize%=endline%-lineadd% ' mem_needed%=(linesize%+undosize%)*2 IF FRE(0)>mem_needed% THEN ' IF linesize%>1 THEN line$=SPACE$(linesize%-1) BMOVE lineadd%,V:line$,linesize%-1 ELSE line$="" ENDIF ' IF undosize%>1 THEN undo$=SPACE$(undosize%-1) BMOVE undobuffer%,V:undo$,undosize%-1 ELSE undo$="" ENDIF ' replace(lineadd%,line$,undo$) refresh_curr_line get_curpos update_column cursor_on lineupdated!=FALSE line$="" undo$="" ELSE request("Cannot Undo The Changes on Current Line!|Not Enough Internal Memory For Operation|(The Line Is Too Long).","WHAT A SACK OF SHIT","",x%) ENDIF ENDIF RETURN > PROCEDURE text2document(curkey$) ' ' Inserts a character into the document at the current ' cursor position. CHAR_INSERTED! is set to true if ' a character is used. ' IF curkey$<>"" AND NOT (ie_ramiga!) THEN ' ' check that a macro key wasn't pressed ... ' IF (NOT ie_alt!) OR ((event_code%<>&H37) AND (event_code%<>&H36) AND (event_code%<>&H35) AND (event_code%<>&H13) AND (event_code%<>&H28) AND (event_code%<>&H21)) THEN IF curkey$=CHR$(tab%) AND tab2space! THEN ' ' Tab key pressed and user wants tabs converted to spaces ... ' get_cursorx FOR laura%=1 TO (tabsize%-MOD(cursorx%+indent%,tabsize%)) insert_char(" ") NEXT laura% char_inserted!=TRUE ELSE IF (curkey$>=CHR$(32) AND curkey$=CHR$(161) OR curkey$=CHR$(tab%) OR curkey$=CHR$(27) IF LEFT$(curkey$,1)="|" THEN curkey$=RIGHT$(curkey$,1) ENDIF insert_char(curkey$) char_inserted!=TRUE ELSE IF curkey$=CHR$(8) AND (NOT ie_shift!) back_space_char char_inserted!=TRUE ENDIF ENDIF ENDIF RETURN > PROCEDURE goto_top_of_file ' ' Used to reset the cursor position after an operation which can ' totally muck up all of the address pointers (e.g. Tabs2Space) ' curline%=1 curradd%=docstart% lineadd%=docstart% cursorx%=0 cursory%=0 topadd%=docstart% indent%=0 refresh_page update_prop update_line update_column cursor_on make_undo_string RETURN > PROCEDURE create_abyss ' ' Creates an "abyss" at the end of the current line. ' This is a technique which I devised so that text insertion would be ' as fast on a file of 1K as on a file of 100K. Normally, when I inserted ' a character, I moved every byte from the current address to the end of ' the document up one byte - this proved to be quite slow on files >50K ' So now, whenever a character is inserted, then a space is allocated at ' the end of the current line which acts as a small buffer. Once this ' buffer has been allocated, then on the next insertion we only need to ' move memory addresses upto the end of the current line. (until the ' buffer reduces to 0bytes, in which case, we allocate a new one) ' IF abyss%=0 THEN abyssend%=lineadd% next_line(abyssend%) abyss%=90 BMOVE abyssend%,abyssend%+abyss%,docstart%+noofchars%-abyssend%+1 abyssend%=abyssend%+abyss% ENDIF RETURN > PROCEDURE free_abyss ' ' Frees any buffer space that was allocated at the end of the line ' before we move onto another line. To get a slightly fuller description ' of the "abyss" technique that I dreamt up, refer to the create_abyss proc. ' IF abyss%>0 THEN BMOVE abyssend%,abyssend%-abyss%,docstart%+noofchars%+abyss%-abyssend%+1 abyss%=0 ENDIF RETURN ' **************************** SCREEN ROUTINES ****************************** > PROCEDURE refresh_line(line%,VAR address%) ' ' This program will display one line of text starting at address ' location ADDRESS on line number LINE of the screen. It will then ' move ADDRESS to the end of line (if not already there) and pass ' this value back out. i.e. the parameter ADDRESS will be updated. ' ' ' Calculate what colour to print the text in ' IF NOT supress_view! THEN rport%={winptr%(0)+50} ~SetAPen(rport%,1) ~SetBPen(rport%,0) IF blockon! THEN IF address%>=blockstart% AND address%2 THEN ~SetAPen(rport%,2) ~SetBPen(rport%,3) ELSE ~SetAPen(rport%,0) ~SetBPen(rport%,1) ENDIF ENDIF ENDIF tempadd%=address% ' ' Allocate some memory for the current line ' maxsize%=maxcol%+indent% line_buffer%=AllocMem(maxsize%+30,1) IF line_buffer%=0 THEN inform("Not Enough Memory To Display Line!|Line Too Long (over "+STR$(maxcol%+indent%+30)+" bytes)|Reverting to start of line") ~SetAPen(rport%,1) ~SetBPen(rport%,0) indent%=0 cursorx%=0 maxsize%=maxcol% curradd%=lineadd% line_buffer%=AllocMem(maxsize%+30,1) ENDIF ' ' Use a custom machine code routine to convert all tabs into spaces. ' BMOVE V:blank_line$,line_buffer%+indent%,maxcol% clear_registers reg%(8)=V:address% ! A0=text address (lineadd) reg%(9)=line_buffer% ! A1=buffer address reg%(10)=V:maxsize% ! A2=max buffer length reg%(11)=V:tabsize% ! A3=current tab size reg%(5)=showlinefeeds! ! D5=boolean show line feeds RCALL mc68000convertstring%,reg%() ' ' Display the line of text on screen ' IF use_wbench! THEN ~Move(rport%,wboffset_x%,SHL(line%,3)+6+text_offset%+wboffset_y%) ELSE ~Move(rport%,0,SHL(line%,3)+6+text_offset%) ! SHL(x,3) = x*8 ENDIF ~Text(rport%,line_buffer%+indent%,maxcol%) ' ' Invert any region of vertical block which is visible on screen ' IF blockon! THEN IF vertblock! THEN IF tempadd%>=vertstart% AND tempadd%<=vertend% AND tempadd%>0 THEN IF vertx1%<=indent%+maxcol% THEN x1%=MAX(vertx1%-indent%,0) x2%=MIN(vertx2%-indent%,maxcol%) ' xor_region(0,SHL(x1%,3),SHL(line%,3)+text_offset%,SHL(x2%,3)-1,SHL(line%,3)+7+text_offset%) ENDIF ENDIF ENDIF ENDIF ' ' Return the allocated memory ' ~FreeMem(line_buffer%,maxsize%+30) ENDIF RETURN > PROCEDURE refresh_page_nocursor ' ' This procedure redraws the whole screen. The routine is interruptable ' if there is a keypress. The routine checks to see if a PgUp or PgDn ' key was pressed and calls itself recursively, if this is the case, ' for the new area of document. If any other keypress is made, then ' it is stored in a buffer and then each character is inserted into ' the document after the refresh has finished. ' LOCAL l%,moved!,buffer$ ' free_abyss tempaddr%=topadd% endaddress%=docstart%+noofchars%-1 moved!=FALSE buffer$="" ' ' Refresh the page ' FOR l%=0 TO maxrow%-1 refresh_line(l%,tempaddr%) ' IF tempaddr%>=endaddress% THEN tempaddr%=0 ELSE IF tempaddr%<>0 tempaddr%=tempaddr%+1 ENDIF ' ' test for a keypress ... ' IF NOT playing_macro! THEN test_events(0) IF event_key$<>"" THEN IF NOT quick_refresh! THEN IF (event_key$=shiftup$) AND (topadd%>docstart%) THEN page_up moved!=TRUE ELSE IF (event_key$=shiftdown$) AND (curline%-cursory%"" THEN REPEAT key$=LEFT$(buffer$,1) ! get next character from buffer buffer$=RIGHT$(buffer$,LEN(buffer$)-1) ! and remove it from the buffer text2document(key$) UNTIL buffer$="" refresh_curr_line @get_cursorx ENDIF ' IF NOT supress_view! THEN caroline!=TRUE ENDIF RETURN > PROCEDURE refresh_page ' ' This procedure redraws the whole screen and switches the cursor back on ' refresh_page_nocursor cursor_on RETURN > PROCEDURE refresh_from_line ' ' This procedure redraws the screen from the current line ' This is used when an operation (e.g. line feed) changes only ' the lower few lines and not neccessarily the whole screen ' therefore making the refresh slightly than faster than a complete redraw ' tempaddr%=lineadd% endaddress%=docstart%+noofchars%-1 FOR l%=cursory% TO maxrow%-1 refresh_line(l%,tempaddr%) IF tempaddr%>=endaddress% OR tempaddr%=0 THEN tempaddr%=0 ELSE tempaddr%=tempaddr%+1 ENDIF NEXT l% cursor_on RETURN > PROCEDURE refresh_curr_line tempaddr%=lineadd% refresh_line(cursory%,tempaddr%) RETURN > PROCEDURE refresh_range(startx%,endx%) ' ' refreshes the page from vertical cursor position startx to endx where ' these can take values from 0..maxrow-1 ' endaddress%=docstart%+noofchars%-1 range_address%=topadd% range_lineno%=0 ' WHILE range_lineno%=endaddress% OR range_address%=0 THEN range_address%=0 ELSE range_address%=range_address%+1 ENDIF range_lineno%=range_lineno%+1 WEND RETURN > PROCEDURE refresh_view ' ' There is an ARexx command called View ON/OFF which lets the ' user suspend output of any changes to the screen in order ' to increase the speed of an ARexx script. This routine ' performs all the necessary screen updates required when a ' View ON command is received. (also called by CTRL+A) ' supress_view!=FALSE update_prop update_line update_column update_tab update_docno update_mode update_case_flag refresh_page message("") cursor_on RETURN > PROCEDURE open_window(number%,wx%,wy%,width%,height%,title$) ' ' Opens a window and sets up the default window style. ' If SYSGADGETS! is false, then the new look system gadgets are used. ' If an error occured opening the window, then WINDOWERROR! will be true. ' okay!=FALSE cancel!=FALSE unable_to_open_window!=FALSE string_position%=100 ! Initial cursor in string gadget = EOL ' set_case_if_changed IF winptr%(0)<>0 AND hide_cursor! THEN cursor_off ENDIF ' ' Refresh line if Strip EOL Blank and Show LF's is on. Because the ' display may leave a little LF character floating around ' IF showlinefeeds! AND strip_eol! THEN refresh_curr_line get_cursorx ENDIF ' ' Calculate the y-coord for the window to be centred on screen ' IF wy%>=0 THEN IF currscreen%=0 AND screenres%>300 THEN wy%=(200-height%)/2 ELSE wy%=(screenres%-height%)/2 ENDIF ENDIF wy%=ABS(wy%) wx%=(640-width%) DIV 2 ' ' Set up a NewWindow structure ... ' aimee$=STRING$(48,CHR$(0)) newwindow%=V:aimee$ ' ' Set up some memory for the window title ' title$=title$+CHR$(0) wintitle%(number%)=AllocMem(80,1) IF wintitle%(number%)<>0 THEN BMOVE V:title$,wintitle%(number%),MIN(80,LEN(title$)) ENDIF ' ' Define the x,y position of the ' window and its width & height ' DPOKE newwindow%,wx% DPOKE newwindow%+2,wy% DPOKE newwindow%+4,width% DPOKE newwindow%+6,height% ' ' Define the Detail Pen and ' Block Pen colours ' POKE newwindow%+8,2 POKE newwindow%+9,1 ' ' Define the IDCMP flags to react ' to, and the display flags, and ' store a pointer to the title. ' (IDCMP=RAWKEY+MOUSEBUTTONS) ' LPOKE newwindow%+10,&H608 LPOKE newwindow%+14,&H1100E LPOKE newwindow%+26,wintitle%(number%) ' ' State the screen to display the ' window on. 0=use WorkBench screen. ' The Type field is set to CUSTOMSCREEN ' or WBENCHSCREEN accordingly ' IF scrptr%(1)=0 THEN DPOKE newwindow%+46,1 LPOKE newwindow%+30,0 ELSE DPOKE newwindow%+46,15 LPOKE newwindow%+30,scrptr%(1) ENDIF ' ' Open the window and store its handle ' winptr%(number%)=OpenWindow(newwindow%) IF winptr%(number%)<>0 THEN ' currwindow%=number% winwidth%(currwindow%)=width% winheight%(currwindow%)=height% ' ' Use EdWord's new look system gadgets ' colour1(currwindow%,backcol%) pbox(currwindow%,4,PEEK(winptr%(number%)+55),width%-5,height%-3) set_font(currwindow%) set_pointer(1) ' ELSE alert("Memory Too Low To Open A Window!") unable_to_open_window!=TRUE ENDIF RETURN > PROCEDURE close_window(windowno%) ' ' Just a number of operations that are performed when every window closes ' So why not group them together into one procedure and pretend that ' I am actually writting good,structured,modular code! ' IF winptr%(windowno%)<>0 THEN set_pointer(0) ~CloseWindow(winptr%(windowno%)) winptr%(windowno%)=0 ' ' Return the memory for the window's title ' IF wintitle%(windowno%)<>0 THEN ~FreeMem(wintitle%(windowno%),80) ENDIF ' ' find the next opened window to be activated ... ' currwindow%=5 WHILE winptr%(currwindow%)=0 AND currwindow%>0 currwindow%=currwindow%-1 WEND ' IF currwindow%=0 THEN message("") ' IF DPEEK(winptr%(0)+10)<99 THEN clear_registers reg%(8)=winptr%(0) reg%(14)=_IntBase RCALL _IntBase-&H1F8,reg%() PAUSE 10 refresh_window ENDIF ' cursor_on ignore_messages ELSE set_pointer(1) ENDIF ENDIF ' abortgadget!=FALSE ' RETURN > PROCEDURE activate(windowno%) ' ' Activates a window so that it will be used ' for all default output ' IF winptr%(windowno%)<>0 THEN currwindow%=windowno% ENDIF RETURN PROCEDURE window_title(windowno%,title$) ' ' This will set the screen title of the EdWord screen ' If the user has not specified a filename then you've got ' my name in lights, otherwise, the filename is displayed ' The parameter WINDOWNO is used to tell the procedure which ' window it is setting the title for. ' LOCAL aimee$ ' IF docupdated! OR lineupdated! THEN append$=modified_text$ ELSE append$="" ENDIF ' INLINE screennamebuffer%,80 INLINE windownamebuffer%,80 ' IF windowno%=0 AND use_wbench! THEN aimee$=screenname$+" Editor"+CHR$(0) BMOVE V:aimee$,screennamebuffer%,LEN(aimee$) IF recording_macro! THEN aimee$=screenname$+" - Recording Macro..." ELSE IF curfilename$="" aimee$=screenname$+" - "+author2$+" 1994" ELSE aimee$=screenname$+" - "+curfilename$+append$ ENDIF aimee$=LEFT$(aimee$,78)+CHR$(0) BMOVE V:aimee$,windownamebuffer%,LEN(aimee$) IF winptr%(0)<>0 THEN ~SetWindowTitles(winptr%(0),windownamebuffer%,screennamebuffer%) ENDIF ELSE IF recording_macro! THEN aimee$=screenname$+" - Recording Macro..." ELSE IF curfilename$="" aimee$=screenname$+" - "+author2$+" 1994" ELSE aimee$=screenname$+" - "+curfilename$+append$ ENDIF aimee$=LEFT$(aimee$,78)+CHR$(0) BMOVE V:aimee$,screennamebuffer%,LEN(aimee$) aimee$=screenname$+" Text Editor"+CHR$(0) BMOVE V:aimee$,windownamebuffer%,LEN(aimee$) IF winptr%(windowno%)<>0 THEN ~SetWindowTitles(winptr%(windowno%),windownamebuffer%,screennamebuffer%) ENDIF ENDIF RETURN > PROCEDURE message(text$) ' ' This procedure will display any given message on the screen bar (or on ' the title bar if run from a workbench screen). This procedure is used ' by such routines as Loading,Saving,Printing etc. If no message is ' supplied, then the default window/screen titles are restored. ' LOCAL aimee$ ' IF text$="" THEN window_title(0,"") ELSE IF use_wbench! THEN aimee$=screenname$+" Editor"+CHR$(0) BMOVE V:aimee$,screennamebuffer%,LEN(aimee$) aimee$=screenname$+" - "+text$+CHR$(0) BMOVE V:aimee$,windownamebuffer%,LEN(aimee$) IF winptr%(0)<>0 THEN ~SetWindowTitles(winptr%(0),windownamebuffer%,screennamebuffer%) ENDIF ELSE POKE windownamebuffer%,0 aimee$=screenname$+" - "+text$+CHR$(0) BMOVE V:aimee$,screennamebuffer%,LEN(aimee$) IF winptr%(0)<>0 THEN ~SetWindowTitles(winptr%(0),windownamebuffer%,screennamebuffer%) ENDIF ENDIF ENDIF RETURN > PROCEDURE update_title_bar IF modified_text! THEN IF (docupdated! OR lineupdated!)<>(old_docupdated! OR old_lineupdated!) THEN message("") ENDIF old_docupdated!=docupdated! old_lineupdated!=lineupdated! ENDIF RETURN > PROCEDURE centre_text(window%,text$,width%,y%) ' ' Centres a line of text at y-coordinate, Y, on a window WIDTH pixels wide. ' text(window%,(width%-LEN(text$)*8) DIV 2,y%,text$) RETURN > PROCEDURE cursor_on ' ' Displays the character under the current position in an inversed colour ' to show the position of the cursor ' IF (NOT supress_view!) AND winptr%(0)<>0 THEN IF use_underline! THEN IF alternate_cursor! THEN ~SetAPen(rastport%,col3%) IF blockon! THEN IF vertblock! THEN IF lineadd%>=vertstart% AND lineadd%<=vertend% THEN IF cursorx%+indent%>=vertx1% AND cursorx%+indent%=blockstart% AND lineadd%=vertstart% AND lineadd%<=vertend% THEN IF cursorx%+indent%>=vertx1% AND cursorx%+indent%=blockstart% AND curradd%=vertstart% AND lineadd%<=vertend% THEN IF cursorx%+indent%>=vertx1% AND cursorx%+indent%=blockstart% AND lineadd% PROCEDURE cursor_off ' ' Displays the character under the cursor in normal colours - i.e. this ' has the desired effect of turning off the little cursor. ' IF (NOT supress_view!) AND winptr%(0)<>0 THEN ~SetAPen(rastport%,col1%) ~SetBPen(rastport%,col0%) IF blockon! AND curradd%>=blockstart% AND curradd%2 THEN ~SetAPen(rastport%,col2%) ~SetBPen(rastport%,col3%) ELSE ~SetAPen(rastport%,col0%) ~SetBPen(rastport%,col1%) ENDIF ENDIF display_cursor ' IF blockon! AND vertblock! IF lineadd%>=vertstart% AND lineadd%<=vertend% THEN IF cursorx%+indent%>=vertx1% AND cursorx%+indent% PROCEDURE flash_cursor ' ' If the user has selected Flash on, then this routine will handle the ' flashing of the cursor. This is done every half second (TIMER returns ' the time since the system was turned on in 200ths of a second) ' IF flash_gordon! THEN IF EVEN(TIMER DIV 100) THEN cursor_on ELSE cursor_off ENDIF ENDIF RETURN > PROCEDURE display_cursor ' ' Displays the current cursor at its x,y position on screen ' IF winptr%(0)<>0 THEN IF docstart%<>0 THEN IF PEEK(curradd%)=lf% THEN IF showlinefeeds! AND (NOT lineoverflow!) THEN a$=CHR$(182) ! use a PI sign for line feeds ELSE a$=" " ! do not display anything for line feeds ENDIF ELSE IF PEEK(curradd%)=tab% a$=" " ELSE a$=CHR$(PEEK(curradd%)) ENDIF ELSE a$=" " ! standard cursor if no memory allocated yet ENDIF ' IF use_wbench! THEN ~Move(rastport%,cursorx%*8+wboffset_x%,cursory%*8+6+text_offset%+wboffset_y%) ELSE ~Move(rastport%,cursorx%*8,cursory%*8+6+text_offset%) ENDIF ~Text(rastport%,V:a$,1) ENDIF RETURN > PROCEDURE set_alternate_cursor ' ' sets the colour system for the alternative and standard cursor ' IF alternate_cursor! THEN cursor_fore%=2 cursor_back%=3 ELSE cursor_fore%=0 cursor_back%=1 ENDIF RETURN > PROCEDURE get_cursorx ' ' This one will work out the new screen cursor x-coordinate of the ' current character given that we know the address of it in memory ' unfortunately these two numbers aren't the same because of one ' little (annoying) thing :- tabs! i.e. 2 tab characters = 2 memory ' locations from the start of the line but something like 16 cursor ' positions (depending upon the tab size) ' The procedure will update a boolean variable called REFRESH!. This ' will be true if a screen refresh is required - normally because ' new cursorx is off screen. ' clear_registers reg%(8)=V:cursorx% reg%(9)=V:lineadd% reg%(10)=V:curradd% reg%(11)=V:tabsize% RCALL mc68000findcursor%,reg%() ' lineoverflow!=FALSE oldindent%=indent% refresh!=TRUE indent%=0 WHILE cursorx%>=maxcol% indent%=indent%+scrollsize% cursorx%=cursorx%-scrollsize% WEND ' IF indent%=oldindent% THEN refresh!=FALSE ENDIF RETURN > PROCEDURE get_curpos ' ' This procedure performs the opposite function to get_cursorx ' i.e. it works out the memory address of a character given that ' we know its cursor x-coordinate. ' curradd%=lineadd% offset%=0 WHILE offset%lf% IF PEEK(curradd%)=tab% THEN offset%=offset%+(tabsize%-MOD(offset%,tabsize%)) ELSE offset%=offset%+1 ENDIF curradd%=curradd%+1 WEND ' IF offset%>cursorx%+indent% THEN curradd%=curradd%-1 ENDIF ' IF PEEK(curradd%)=lf% AND (offset% PROCEDURE insert_char(key$) IF noofchars%+memlow%>=memorysize% THEN memory_alert ELSE check_for_word_wrap(key$) IF key$<>"" THEN create_abyss IF PEEK(curradd%)=lf% OR textmode%=0 THEN BMOVE curradd%,curradd%+1,abyssend%-curradd%-1 noofchars%=noofchars%+1 abyss%=abyss%-1 update_block_insert(0,1) ENDIF POKE curradd%,ASC(key$) curradd%=curradd%+1 get_cursorx IF refresh! THEN refresh_page ELSE refresh_curr_line ENDIF cursor_on update_column lineupdated!=TRUE ENDIF ENDIF RETURN > PROCEDURE insert_char_nodisplay(key$) ' ' Inserts the parameter character into the document at the current ' cursor position but does not updates the screen display in any way ' IF key$=CHR$(lf%) THEN update_block_insert(1,1) ELSE IF PEEK(curradd%)=lf% OR textmode%=0 update_block_insert(0,1) ENDIF ' BMOVE curradd%,curradd%+1,docstart%+noofchars%-curradd%+1 noofchars%=noofchars%+1 POKE curradd%,ASC(key$) curradd%=curradd%+1 lineupdated!=TRUE RETURN > PROCEDURE delete_char_nodisplay create_abyss BMOVE curradd%+1,curradd%,abyssend%-curradd%-1 abyss%=abyss%+1 noofchars%=noofchars%-1 update_block_delete_char(0,1) lineupdated!=TRUE RETURN > PROCEDURE check_for_word_wrap(VAR key$) ' LOCAL pos%,old_curradd% ' IF word_wrap! AND (cursorx%+indent%>=word_wrap_cutoff%) THEN old_curradd%=curradd% old_indent%=indent% IF key$<>CHR$(32) AND key$<>CHR$(tab%) THEN ' curradd%=curradd%-1 WHILE (PEEK(curradd%)<>32) AND (PEEK(curradd%)<>tab%) AND (curradd%>lineadd%) curradd%=curradd%-1 WEND ' IF curradd%=lineadd% THEN curradd%=old_curradd% ENDIF ' get_cursorx IF (PEEK(curradd%)=32 OR PEEK(curradd%)=tab%) AND (curradd%<>old_curradd%) delete_char_nodisplay old_curradd%=old_curradd%-1 ENDIF ' ELSE key$="" ENDIF ' line_feed IF old_indent%>0 THEN indent%=0 refresh_page_nocursor ENDIF ' curradd%=old_curradd%+1 get_cursorx ' ENDIF RETURN > PROCEDURE back_space_char ' ' implements "BackSpace" character delete ' cursor_off IF curradd%>lineadd% THEN curradd%=curradd%-1 delete_char_nodisplay get_cursorx IF refresh! THEN refresh_page ELSE refresh_curr_line ENDIF ELSE IF curline%>1 THEN free_abyss curradd%=curradd%-1 prev_line(lineadd%) delete_char_nodisplay free_abyss get_cursorx curline%=curline%-1 cursory%=cursory%-1 nooflines%=nooflines%-1 IF blockon! THEN beforeend%=blockend% prev_line(beforeend%) IF lineadd%=beforeend% THEN blockend%=blockend%-1 next_line(blockend%) ENDIF ENDIF IF cursory%<0 THEN cursory%=cursory%+1 prev_line(topadd%) refresh!=TRUE ENDIF ' IF refresh! THEN refresh_page ELSE refresh_curr_line next_line(lineadd%) scroll_part_up(cursory%+1) prev_line(lineadd%) ENDIF update_line move_marks(-1) ELSE get_cursorx ENDIF update_prop make_undo_string ENDIF update_column cursor_on RETURN > PROCEDURE del_char ' ' implements "Del" character delete ' cursor_off IF PEEK(curradd%)<>lf% THEN delete_char_nodisplay get_cursorx IF refresh! THEN refresh_page ELSE refresh_curr_line ENDIF ELSE IF (eol_overflow!) AND (curline%1) free_abyss BMOVE curradd%+1,curradd%,docstart%+noofchars%-curradd%+1 noofchars%=noofchars%-1 nooflines%=nooflines%-1 get_cursorx refresh_from_line ENDIF update_column cursor_on RETURN > PROCEDURE line_feed ' ' What happens when the user presses the RETURN key. This includes setting ' the case for the current line (if text casing is on), auto indenting ' the next line (if auto indent on), checking for symbolic indenting (if ' symbolic indenting is on). As well as checking for having to scroll the ' screen up if at the bottom of the screen and all the usual mallacy. ' IF noofchars%+memlow%>=memorysize% THEN memory_alert ELSE cursor_off oldindent%=indent% lineupdated!=TRUE ' get_autoindent_string(auto_indent$) ' set_case_if_changed insert_char_nodisplay(CHR$(lf%)) indent_symbolically(auto_indent$) ' refresh_curr_line next_line(lineadd%) ' indent_line(auto_indent$) get_cursorx ' move_marks(1) cursory%=cursory%+1 curline%=curline%+1 nooflines%=nooflines%+1 IF cursory%>=maxrow% THEN scroll_up IF refresh! THEN refresh_page ENDIF ELSE IF refresh! THEN refresh_page ELSE scroll(0,-8,0,cursory%*8+text_offset%,maxcol%*8,maxrow%*8-1+text_offset%) refresh_curr_line ENDIF ENDIF ' IF nooflines%>=maxrow%-1 THEN update_prop ENDIF ' cursor_on update_line update_column make_undo_string ENDIF RETURN > PROCEDURE insert_fkey(code$) ' ' Inserts the equivalent text section for an F-Key as set by the ' DEFINE F-KEYS routine. It accepts the keyboard code for the f-keys ' as returned by INKEY$ for an input via CODE$. ' This routine is also used by the Repeat Text routine to insert the ' text which the user selects (this is done by reserving a space for ' an inmaginary F11 key) ' LOCAL size% cursor_off fkey%=VAL(MID$(code$,2,2)) size%=LEN(fkey$(fkey%)) IF noofchars%+size%+memlow%>memorysize% THEN memory_alert ELSE ' BMOVE curradd%,curradd%+size%,docstart%+noofchars%-curradd%+size%+abyss% abyssend%=abyssend%+size% ' refresh_it!=FALSE rachel%=0 FOR l%=0 TO size%-1 next_char%=ASC(MID$(fkey$(fkey%),l%+1,1)) POKE curradd%+l%,next_char% IF next_char%=lf% THEN nooflines%=nooflines%+1 curline%=curline%+1 rachel%=rachel%+1 IF cursory%0 THEN lineupdated!=TRUE ENDIF ENDIF RETURN > PROCEDURE insert_text(address%,text$) ' ' Inserts a given piece of text into memory and updates the count ' of characters. This routine will also check for enough memory ' to perform the insert operation. ' LOCAL size% size%=LEN(text$) IF noofchars%+size%+memlow%>memorysize% THEN memory_alert ELSE BMOVE address%,address%+size%,docstart%+noofchars%-address%+size% ' FOR l%=0 TO size%-1 POKE address%+l%,ASC(MID$(text$,l%+1,1)) NEXT l% ' noofchars%=noofchars%+size% ENDIF RETURN > PROCEDURE mouse_hit ' ' Performs various operations when the left button is clicked, depending ' upon where the cursor is. The following functions are performed :- ' ' 1) If mouse over prop gadget, gadget is repositioned ' 2) If mouse over text, then cursor is repositioned ' 3) If mouse over a scroll gadget, then document scrolled up/down ' 4) If mouse at top of screen (screen/title bar), do nothing ' 5) If mouse draged over text, then define as a horizontal block ' 6) If mouse double clicked over text, then define a vertical block ' LOCAL ann_x%,ann_y% ' IF mouse! AND (winptr%(0)<>0) THEN test_system_gadgets IF mouse! THEN mx%=event_x% my%=event_y% x%=mx% y%=my% IF y%>0 AND y%<=(bottomline% DIV 8)*8 THEN IF x%>=maxcol%*8 THEN ! prop gadget hit IF y%>6 AND y%=split_line% AND y%<=split_line%+6 ' ' click over the split screen dividing line (allows user to drag it) ' drag_split_bar ELSE ! new cursor position cursor_off ' ' Check for click on the other side of a split screen ' IF split_screen! THEN IF (y%<=split_line% AND activesplit%=2) OR (y%>split_line% AND activesplit%=1) THEN switch_to_other_split cursor_off mx%=x% my%=y% ENDIF ENDIF ' ' Display cursor at new position ' ann_x%=cursorx% ann_y%=cursory% position_cursor(x% DIV 8,(y%-text_offset%) DIV 8,FALSE) IF double_click! THEN IF NOT pointer_over_eof! THEN ' ' Double click mouse button to select vertical blocks ' IF (vertstart%=0) OR (vertstart%<>0 AND cursorx% PROCEDURE prop_hit ' ' Detects whether the proportional gadget was selected and if so, it will ' allow the user to drag it to a new position and then jump to the new ' offset in the file and refresh the display. ' LOCAL smoothstep% ' prop_hit!=TRUE smoothstep%=30 oldpos=INT(((curline%-cursory%-1)/nooflines%)*maxpot%) propsize=maxrow%/nooflines% oldcursorx%=cursorx% oldcursory%=cursory% refresh!=FALSE y%=event_y%-12 propsize=INT(MIN(propsize,1)*maxpot%) newpos=MAX(INT(y%-(propsize/2)),0) free_abyss ' py%=y%-oldpos IF py%<0 THEN oldpos=MAX(oldpos-propsize,0) refresh!=TRUE ELSE IF py%>propsize oldpos=MIN(oldpos+propsize,maxpot%-propsize) refresh!=TRUE ELSE ' display_prop(2) check_mouse_click x%=cursorx%*8 cursor_off WHILE mouse! y%=event_y%-12 newpos=MAX(INT(y%-(propsize/2)),0) newpos=MIN(newpos,maxpot%-propsize) ' temp%=INT((newpos*nooflines%)/maxpot%)+1 deltay%=temp%-curline%+cursory% ' IF (newpos<>oldpos) THEN proppos=newpos display_prop(2) refresh!=TRUE ENDIF ' IF deltay%<>0 THEN ' ' Update the screen display to the equivalent position designated ' by the position of the prop gadget. ' IF deltay%>0 AND deltay%<=smoothstep% THEN move_down_one_line ELSE IF deltay%<0 AND deltay%>=-smoothstep% move_up_one_line ELSE goto_line(temp%,FALSE,FALSE) ! jump to the new position refresh_page_nocursor ! refresh page position_cursor(oldcursorx%,oldcursory%,TRUE) ! position the cursor IF topadd%<=docstart% THEN curline%=cursory%+1 ! ensure coords are correct topadd%=docstart% ENDIF ENDIF ENDIF ' oldpos=newpos test_events(0) WEND display_prop(1) ENDIF prop_hit!=FALSE ' IF refresh! THEN proppos=newpos temp%=INT((oldpos*nooflines%)/maxpot%)+1 goto_line(temp%,FALSE,FALSE) ! jump to the new position update_prop refresh_page_nocursor ! refresh page position_cursor(oldcursorx%,oldcursory%,TRUE) ! position the cursor IF topadd%<=docstart% THEN curline%=cursory%+1 ! ensure coords are correct topadd%=docstart% ENDIF ENDIF ' RETURN > PROCEDURE position_cursor(x%,y%,force!) ' ' Moves the current cursor to a new coordinate on the current page of text. ' The procedure checks for out of range coordinates and converts them into ' legal values if necessary ' ' X = 0..maxcol-1 ' Y = 0..maxrow-1 ' FORCE! = if false, then the move will only be performed if the coordinates ' differ from the current cursor position, otherwise it will be done ' in any case. ' x%=MAX(0,x%) y%=MAX(0,y%) ' IF x%=-1 THEN ! x=-1 possible when on workbench with gimme00 x%=0 ENDIF IF x%>=maxcol% THEN ! x coord is over the prop-gadget x%=maxcol%-1 ENDIF IF y%>=maxrow% THEN ! y coord is over status bar y%=maxrow%-1 ENDIF ' pointer_over_eof!=FALSE IF cursorx%<>x% OR cursory%<>y% OR force! THEN set_case_if_changed curline%=curline%-cursory% cursory%=y% cursorx%=x% WHILE curline%+cursory%>nooflines% pointer_over_eof!=TRUE cursory%=cursory%-1 WEND curline%=curline%+cursory% lineadd%=topadd% FOR l%=0 TO cursory%-1 next_line(lineadd%) NEXT l% curradd%=lineadd% get_curpos update_line update_column ENDIF RETURN > PROCEDURE test_system_gadgets ' ' Tests to see if a mouse click was over one of the two scroll gadgets ' which appear as arrows above and below the prop gadget. If one has ' been selected, then a scroll in the appropriate direction is performed. ' This procedure should only be called once a mouse click has been ' detected as the procedure itself does not check for this. ' LOCAL x%,y% FOR test%=1 TO 2 x%=event_x% y%=event_y% IF (x%>=sysgad%(test%,0)-4) AND (y%>=sysgad%(test%,1)-1) AND (y% PROCEDURE update_line ' ' Displays the current line number on the status bar at bottom of screen ' IF winptr%(0)<>0 THEN a$=LEFT$(STR$(curline%)+" ",6) status_bar_colour rport%={winptr%(0)+50} IF use_wbench! THEN ~Move(rport%,48+wboffset_x%,bottomline%+9+wboffset_y%) ELSE ~Move(rport%,48,bottomline%+9) ENDIF ~Text(rport%,V:a$,LEN(a$)) update_cur_char ENDIF RETURN > PROCEDURE update_column ' ' Displays the current column number on the status bar at bottom of screen ' IF winptr%(0)<>0 THEN IF NOT supress_view! THEN a$=LEFT$(STR$(cursorx%+indent%+1)+" ",6) status_bar_colour rport%={winptr%(0)+50} IF use_wbench! THEN ~Move(rport%,160+wboffset_x%,bottomline%+9+wboffset_y%) ELSE ~Move(rport%,160,bottomline%+9) ENDIF ~Text(rport%,V:a$,LEN(a$)) update_cur_char ENDIF ENDIF RETURN > PROCEDURE update_cur_char ' ' Displays the ASCII value of the current character on the ' status bar at the bottom of the screen ' IF winptr%(0)<>0 AND screenwidth%>=555 THEN IF PEEK(curradd%)=lf% THEN a$="EOL" ELSE IF hexascii! THEN a$=HEX$(PEEK(curradd%)) a$="$"+RIGHT$("0"+a$,2) ELSE a$=STR$(PEEK(curradd%)) a$=RIGHT$("00"+a$,3) ENDIF ENDIF IF curline%=nooflines% AND a$="EOL" THEN a$="EOF" ENDIF status_bar_colour rport%={winptr%(0)+50} IF use_wbench! THEN ~Move(rport%,492+wboffset_x%,bottomline%+9+wboffset_y%) ELSE ~Move(rport%,492,bottomline%+9) ENDIF ~Text(rport%,V:a$,LEN(a$)) ENDIF RETURN > PROCEDURE update_tab ' ' Displays the current tab size on the status bar at bottom of screen ' IF winptr%(0)<>0 THEN a$=STR$(tabsize%)+" " status_bar_colour rport%={winptr%(0)+50} IF use_wbench! THEN ~Move(rport%,248+wboffset_x%,bottomline%+9+wboffset_y%) ELSE ~Move(rport%,248,bottomline%+9) ENDIF ~Text(rport%,V:a$,LEN(a$)) ENDIF RETURN > PROCEDURE update_docno ' ' Displays the current document number on the satus bar. This will be ' either 1 or 2. ' IF winptr%(0)<>0 AND screenwidth%>=374 THEN a$=STR$(curr_docno%+1)+" " status_bar_colour rport%={winptr%(0)+50} IF use_wbench! THEN ~Move(rport%,325+wboffset_x%,bottomline%+9+wboffset_y%) ELSE ~Move(rport%,325,bottomline%+9) ENDIF ~Text(rport%,V:a$,LEN(a$)) ENDIF RETURN > PROCEDURE update_mode ' ' Displays the current editting mode on the status bar. The mode can either ' be Insert mode or Destroy (overwrite) mode. ' IF winptr%(0)<>0 AND screenwidth%>=410 THEN status_bar_colour rport%={winptr%(0)+50} IF use_wbench! THEN ~Move(rport%,354+wboffset_x%,bottomline%+9+wboffset_y%) ELSE ~Move(rport%,354,bottomline%+9) ENDIF IF textmode%=0 THEN a$="INS" ELSE a$="OVR" ENDIF ~Text(rport%,V:a$,3) ENDIF RETURN > PROCEDURE update_time ' ' Displays the current time on the status bar at bottom of screen ' IF winptr%(0)<>0 AND screenwidth%>=497 THEN status_bar_colour rport%={winptr%(0)+50} IF use_wbench! THEN ~Move(rport%,399+wboffset_x%,bottomline%+9+wboffset_y%) ELSE ~Move(rport%,399,bottomline%+9) ENDIF b$=TIME$ ~Text(rport%,V:b$,LEN(b$)) ENDIF RETURN > PROCEDURE update_num_lock ' ' This procedure controls the `NumL' light on the status bar - This ' shows the current status of the Number Lock. When NumL shows on the ' status bar, then the numeric pad acts like a pad of numbers, bur when ' it is off, it acts like a second cursor pad. ' IF winptr%(0)<>0 AND screenwidth%>=600 THEN status_bar_colour IF keypad! THEN a$="NumL" ELSE a$=" " ENDIF rport%={winptr%(0)+50} IF use_wbench! THEN ~Move(rport%,537+wboffset_x%,bottomline%+9+wboffset_y%) ELSE ~Move(rport%,537,bottomline%+9) ENDIF ~Text(rport%,V:a$,4) ENDIF RETURN > PROCEDURE update_case_flag ' ' If text casing has been put on, then this procedure will display a small ' flag on the status bar saying `CAS' - to show this. Otherwise, no such ' flag is printed. ' IF winptr%(0)<>0 AND screenwidth%>=640 THEN status_bar_colour IF keywordcase%<>0 THEN a$="Cas" ELSE a$=" " ENDIF rport%={winptr%(0)+50} IF use_wbench! THEN ~Move(rport%,584+wboffset_x%,bottomline%+9+wboffset_y%) ELSE ~Move(rport%,584,bottomline%+9) ENDIF ~Text(rport%,V:a$,3) ENDIF RETURN > PROCEDURE toggle_mode textmode%=(textmode%+1) MOD 2 update_mode RETURN > PROCEDURE toggle_numlock keypad!=NOT keypad! update_num_lock RETURN > PROCEDURE toggle_hexascii hexascii!=NOT hexascii! update_cur_char forget_ascii_screen RETURN > PROCEDURE toggle_cas IF keywordsloaded! THEN IF keywordcase%=0 THEN keywordcase%=defaultkeycase% ELSE keywordcase%=0 ENDIF update_case_flag ' ELSE inform("Keyword Definition File Not Loaded.|Cannot Toggle Text Casing Mode.") ENDIF RETURN > PROCEDURE status_bar_colour ' ' This procedure will display a piece of text on the status bar ' of the editor window at the specified x-coordinate ' IF screencolours%>2 THEN colour2(0,3,0) ELSE colour2(0,1,0) ENDIF RETURN ' *********************** BLOCK OPERATION PROCEDURES ************************ > PROCEDURE start_of_block(address%,mode%) ' ' Sets the start of the horizontal block to the memory address, ADDRESS. ' MODE can take the following values :- ' 0 = make any page refreshes necessary and put cursor back on ' 1 = make any page refreshes necessary ' 2 = make no page refreshes ' blockstart%=address% refresh!=FALSE IF blockend%<=blockstart% OR blockend%=0 blockend%=0 IF blockon! AND NOT vertblock! THEN blockon!=FALSE refresh!=TRUE ENDIF ELSE blockon!=TRUE vertblock!=FALSE vertstart%=0 vertend%=0 refresh!=TRUE ENDIF ' IF refresh! THEN IF mode%<2 THEN refresh_page_nocursor ENDIF IF mode%=0 THEN cursor_on ENDIF ENDIF ' start_block_line%=curline% ' RETURN > PROCEDURE end_of_block(address%,mode%) ' ' Sets the end of the horizontal block to the memory address, ADDRESS. ' MODE can take the following values :- ' 0 = make any page refreshes necessary and put cursor back on ' 1 = make any page refreshes necessary ' 2 = make no page refreshes ' blockend%=address% refresh!=FALSE IF blockstart%>=blockend% OR blockstart%=0 blockstart%=0 IF blockon! AND NOT vertblock! THEN blockon!=FALSE refresh!=TRUE ENDIF ELSE blockon!=TRUE vertblock!=FALSE vertstart%=0 vertend%=0 refresh!=TRUE ENDIF ' IF refresh! THEN IF mode%<2 THEN refresh_page_nocursor ENDIF IF mode%=0 THEN cursor_on ENDIF ENDIF RETURN > PROCEDURE vert_block_start vertstart%=lineadd% vertstartline%=curline% vertx1%=cursorx%+indent% IF vertend%=vertx2% OR vertend%=0 vertend%=0 IF blockon! AND vertblock! THEN blockon!=FALSE refresh_page ENDIF ELSE blockon!=TRUE vertblock!=TRUE blockstart%=0 blockend%=0 refresh_page ENDIF RETURN > PROCEDURE vert_block_end vertend%=lineadd% vertendline%=curline% vertx2%=cursorx%+indent% IF vertstart%>vertend% OR vertx1%>=vertx2% OR vertstart%=0 vertstart%=0 IF blockon! AND vertblock! THEN blockon!=FALSE refresh_page ENDIF ELSE blockon!=TRUE vertblock!=TRUE blockstart%=0 blockend%=0 refresh_page ENDIF RETURN > PROCEDURE block_off ' ' Switches of the current block and resets all block markers ' blockon!=FALSE blockstart%=0 blockend%=0 vertstart%=0 vertend%=0 start_block_line%=0 refresh_page RETURN > PROCEDURE copy_block ' ' Copies a block of text specified by the current block range (Horizontal ' or Vertical) into the clipboard. ' ' ' Free any memory for a previously allocated clipboard first ... ' IF blockon! THEN cursor_off IF clipstart%<>0 AND clipsize%<>0 THEN ~FreeMem(clipstart%,clipsize%) ENDIF ' ' The copy the current block to the clipboard ' error!=FALSE free_abyss IF vertblock! THEN ' ' Vertical block ' message("Copying Vertical Block ...") linesize%=vertx2%-vertx1% clipsize%=(vertendline%-vertstartline%+1)*(linesize%+1) clipstart%=AllocMem(clipsize%,1) IF clipsize%<>0 THEN tempadd%=vertstart% tempclip%=clipstart% REPEAT convert_line(tempadd%,0,a$) ' FOR l%=vertx1%+1 TO vertx2% IF l%>LEN(a$) THEN a%=32 ELSE a%=ASC(MID$(a$,l%,1)) ENDIF POKE tempclip%,a% tempclip%=tempclip%+1 NEXT l% POKE tempclip%,lf% tempclip%=tempclip%+1 ' next_line(tempadd%) UNTIL tempadd%>vertend% blockcopied!=TRUE verticalclip!=TRUE ELSE error!=TRUE ENDIF message("") ELSE ' ' Horizontal block ' clipsize%=blockend%-blockstart% clipstart%=AllocMem(clipsize%,1) IF clipstart%<>0 THEN FOR l%=0 TO clipsize%-1 POKE clipstart%+l%,PEEK(blockstart%+l%) NEXT l% casingwhencopied!=(keywordcase%<>0) blockcopied!=TRUE verticalclip!=FALSE ELSE error!=TRUE ENDIF ENDIF ' ' Deal with any errors ... ' IF error! THEN inform("ATTETION : Could Not Allocate Enough|Memory For The Block !") ENDIF cursor_on ENDIF RETURN > PROCEDURE cut_block ' ' The Cut Block option is simply erasing a block of specified text ' from the document whilst saving it to the clipboard first of all. ' This is easily constructed from the already present routines, as ' can be seen from the size of this procedure :- ' IF vertblock! THEN set_pointer(1) ENDIF ' copy_block erase_block ' set_pointer(0) ' RETURN > PROCEDURE erase_block ' ' This routine will erase a specified block of text from the current ' document. Two different routines are used :- one for normal blocks ' and one for rectangular (vertical) blocks. This procedure does not ' copy the erased text into the clipboard, it is just removed - no ' way back, matey! ' LOCAL before$,after$ ' free_abyss IF blockon! THEN cursor_off IF vertblock! THEN blockon!=FALSE message("Erasing Vertical Block ...") IF lineadd%>=vertstart% AND lineadd%<=vertend% THEN IF cursorx%>=vertx2% THEN cursorx%=cursorx%-vertx2%+vertx1% ENDIF ENDIF ' tempadd%=vertstart% WHILE PEEK(tempadd%-1)<>lf% AND tempadd%>docstart% tempadd%=tempadd%-1 WEND ' WHILE tempadd%<=vertend% convert_line(tempadd%,1,before$) convert_line(tempadd%,0,after$) after$=LEFT$(after$,vertx1%)+MID$(after$,vertx2%+1,LEN(after$)) ' replace(tempadd%,before$,after$) diff%=LEN(after$)-LEN(before$) vertend%=vertend%+diff% IF tempadd%blockstart% THEN refresh!=TRUE temp_line%=curline% ENDIF ' BMOVE blockstart%+size%,blockstart%,docstart%+noofchars%-blockstart% ' nooflines%=nooflines%-cliplines% noofchars%=noofchars%-size% move_marks(-cliplines%) IF refresh! THEN temp_line%=MAX(MIN(MAX(temp_line%-cliplines%,start_block_line%),nooflines%),1) temp_supress_view!=supress_view! supress_view!=TRUE cursor_bof goto_line(temp_line%,TRUE,TRUE) supress_view!=temp_supress_view! update_line update_column ENDIF ENDIF ' IF noofchars%=0 THEN noofchars%=1 nooflines%=1 topline%=1 lineadd%=docstart% curradd%=docstart% topadd%=docstart% cursory%=0 POKE docstart%+noofchars%-1,10 ELSE IF curradd%>docstart%+noofchars% OR curline%>nooflines% cursor_eof ENDIF ' get_curpos ignore_messages block_off update_prop make_undo_string docupdated!=TRUE ENDIF RETURN > PROCEDURE insert_block LOCAL before$,after$,clip$ IF noofchars%+clipsize%+memlow%>memorysize% THEN memory_alert ELSE free_abyss cursor_off count_lines(clipstart%,clipsize%,cliplines%) IF verticalclip! THEN message("Inserting Vertical Block ...") set_pointer(1) tempadd%=lineadd% tempclip%=clipstart% FOR loop%=1 TO cliplines% convert_line(tempclip%,1,clip$) IF curline%+loop%-1>=nooflines% THEN ! Insert past EOF after$=SPACE$(cursorx%+indent%)+clip$+CHR$(lf%) insert_text(docstart%+noofchars%-1,after$) nooflines%=nooflines%+1 ELSE ! Insert inside current text convert_line(tempadd%,1,before$) convert_line(tempadd%,0,after$) after$=LEFT$(after$+SPACE$(cursorx%+indent%),cursorx%+indent%)+clip$+MID$(after$,cursorx%+indent%+1,LEN(after$)) ' replace(tempadd%,before$,after$) next_line(tempadd%) ENDIF next_line(tempclip%) NEXT loop% set_pointer(0) message("") ELSE BMOVE lineadd%,lineadd%+clipsize%,docstart%+noofchars%-lineadd% ' IF keywordcase%<>0 AND (NOT casingwhencopied!) THEN set_block_case(clipstart%,clipsize%) casingwhencopied!=(keywordcase%<>0) ENDIF ' FOR l%=0 TO clipsize%-1 POKE lineadd%+l%,PEEK(clipstart%+l%) NEXT l% ' nooflines%=nooflines%+cliplines% noofchars%=noofchars%+clipsize% move_marks(cliplines%) ENDIF ' get_curpos block_off update_prop make_undo_string docupdated!=TRUE ENDIF RETURN > PROCEDURE drag_select ' ' Allows a block to be selected by dragging the mouse (with the L.Button ' pressed) over the text required. This is used to select a horizontal ' block definition and will scroll up and down the document if required. ' LOCAL drag!,initmousey%,tempadd% ' drag!=FALSE initmousey%=event_y%-text_offset% check_mouse_click cursor_on WHILE mouse! AND (NOT drag!) IF ABS(event_y%-initmousey%-text_offset%)>7 THEN drag!=TRUE ENDIF test_events(0) WEND upwards!=(event_y%=nooflines%) OR (upwards! AND curline%<=1) THEN drag!=FALSE ENDIF ' IF drag! THEN cursor_off blockend%=0 blockon!=FALSE refresh_direction!=TRUE tempadd%=lineadd% pivotadd%=lineadd% check_mouse_click old_cursory%=cursory% IF upwards! THEN end_of_block(tempadd%,1) prev_line(tempadd%) start_of_block(tempadd%,1) ELSE start_of_block(tempadd%,1) next_line(tempadd%) end_of_block(tempadd%,1) ENDIF ' mouse_y%=MAX(event_y%,text_offset%+1) WHILE mouse! newline%=(mouse_y%-text_offset%) DIV 8 switch_direction!=FALSE old_refresh_direction!=refresh_direction! refresh_direction!=TRUE IF newline%>=maxrow% THEN ' ' >>> SCROLL DOWN - MOUSE AT BOTTOM OF SCREEN <<< ' IF cursory%pivotadd% THEN switch_direction!=TRUE IF old_cursory%=maxrow%-1 THEN refresh_direction!=FALSE ENDIF ELSE next_line(tempadd%) next_line(tempadd%) IF tempadd%>> SCROLL DOWN - MOUSE AT TOP OF SCREEN <<< ' position_cursor(event_x% DIV 8,0,TRUE) IF NOT upwards! THEN IF lineadd%docstart% THEN IF lineadd%>pivotadd% THEN position_cursor(event_x% DIV 8,0,TRUE) IF lineadd%>blockstart% THEN end_of_block(lineadd%,2) prev_line(lineadd%) scroll_down next_line(lineadd%) curline%=curline%-1 cursory%=1 refresh_curr_line cursory%=0 ENDIF ELSE leave!=TRUE switch_direction!=TRUE refresh_direction!=FALSE ENDIF ENDIF ENDIF WEND ENDIF ELSE IF lineadd%>pivotadd% THEN switch_direction!=TRUE ELSE IF lineadd%=blockend% THEN IF lineadd%=docstart% THEN next_line(blockend%) ELSE prev_line(lineadd%) ENDIF ENDIF start_of_block(lineadd%,2) IF old_refresh_direction! THEN refresh_page_nocursor ENDIF ' IF topadd%>docstart% WHILE event_y%<=text_offset% AND mouse! position_cursor(event_x% DIV 8,0,TRUE) IF lineadd%=blockend% THEN prev_line(lineadd%) start_of_block(lineadd%,2) next_line(lineadd%) ELSE start_of_block(lineadd%,2) ENDIF IF topadd%>docstart% prev_line(lineadd%) scroll_down next_line(lineadd%) curline%=curline%-1 cursory%=1 ENDIF refresh_curr_line cursory%=0 test_events(0) WEND ENDIF ENDIF ENDIF old_cursory%=0 ELSE ' ' >>> STILL ON THE SCREEN <<< ' position_cursor(event_x% DIV 8,newline%,TRUE) tempadd%=lineadd% next_line(tempadd%) ' IF NOT upwards! THEN IF tempadd%>blockstart% OR blockstart%=docstart% ! current line after blk start IF tempadd%=blockstart% THEN next_line(tempadd%) ENDIF end_of_block(tempadd%,2) ' IF cursory%>old_cursory% THEN refresh_range(old_cursory%,cursory%) ELSE IF cursory%old_cursory% THEN refresh_range(old_cursory%,cursory%) ELSE IF cursory%"" OR rmouse! THEN ! any key to abort operation ignore_messages block_off cursor_off mouse!=FALSE ENDIF mouse_y%=event_y% WEND position_cursor(event_x% DIV 8,(event_y%-text_offset%) DIV 8,TRUE) update_prop ENDIF cursor_on ' RETURN > PROCEDURE update_block_insert(lines%,quanta%) IF blockon! THEN IF vertblock! THEN IF lineadd% PROCEDURE update_block_delete(lines%,quanta%) IF blockon! THEN IF vertblock! THEN IF lineadd% PROCEDURE update_block_insert_char(lines%,quanta%) IF blockon! THEN IF vertblock! THEN IF lineadd%=vertstart% THEN vertendline%=vertendline%+lines% vertstartline%=vertstartline%+lines% next_line(vertstart%) vertend%=vertend%+quanta% ELSE IF lineadd% PROCEDURE update_block_delete_char(lines%,quanta%) IF blockon! THEN IF vertblock! THEN IF curradd%+1=vertstart% THEN vertstartline%=vertstartline%-lines% vertendline%=vertendline%-lines% prev_line(vertstart%) vertend%=vertend%-quanta% ELSE IF lineadd% PROCEDURE sort_block ' open_window(2,190,50,300,98,"Sort Block") IF NOT unable_to_open_window! THEN draw_box(2,20,15,277,63) colour2(2,pen1%,backcol%) text(2,30,30,"Character Offset :") text(2,30,43," Lines in Block :") text(2,30,55," Sorting Order : ") count_lines(clipstart%,clipsize%,cliplines%) text(2,181,43,STR$(cliplines%)) create_gadget(2,20,73,"SORT",gad1%()) create_gadget(2,212,73,cancel$,gad2%()) ' ascendsort!=NOT ascendsort! flip!=TRUE REPEAT IF flip! THEN ascendsort!=NOT ascendsort! IF ascendsort! THEN create_swirl_gadget(2,180,46,"@ A..Z ",gad3%()) ELSE create_swirl_gadget(2,180,46,"@ Z..A ",gad3%()) ENDIF ENDIF ' string_gadget(2,186,30,4,3,offset$,exit%) offset%=MAX(ABS(INT(VAL(offset$))),1) offset$=STR$(offset%) test_gadget(2,gad3%(),flip!) test_gadget(2,gad1%(),okay!) test_gadget(2,gad2%(),cancel!) IF exit%=2 THEN okay!=TRUE ENDIF UNTIL cancel! OR okay! OR abortgadget! test_gadget_keypress(2,gad1%(),okay!) close_window(2) ' IF okay! THEN cursor_off sort cursor_on ENDIF ENDIF RETURN > PROCEDURE sort ' ' Sorts a block .... called by Sort_Block() and ARexx_command() ' IF cliplines%>1 AND blockcopied! THEN offset%=MAX(offset%,1) totalmem%=6*cliplines%+clipsize% IF totalmem%>FRE(0)-1024 THEN inform("Not Enough Memory|To Perform Sort !") ELSE message("Sorting Block ...") DIM clip$(cliplines%) ' numb%=0 FOR l%=0 TO clipsize%-1 a%=PEEK(clipstart%+l%) IF a%=lf% THEN numb%=numb%+1 ELSE clip$(numb%)=clip$(numb%)+CHR$(a%) ENDIF NEXT l% ' IF ascendsort! THEN QSORT clip$(+) OFFSET offset%-1,cliplines% ELSE QSORT clip$(-) OFFSET offset%-1,cliplines% ENDIF ' numb%=clipstart% FOR l1%=0 TO cliplines%-1 FOR l2%=1 TO LEN(clip$(l1%)) POKE numb%,ASC(MID$(clip$(l1%),l2%,1)) numb%=numb%+1 NEXT l2% POKE numb%,lf% numb%=numb%+1 NEXT l1% ' ERASE clip$() message("") ENDIF ENDIF RETURN > PROCEDURE display_clip_page(topline%) ' colour2(2,pen1%,0) ' topmem%=clipstart% templine%=topline% WHILE templine%>1 next_line(topmem%) templine%=templine%-1 WEND ' FOR sofie%=0 TO 14 ' curline$=SPACE$(maxlinelen%+40) ' IF topline%<=cliplines% THEN clear_registers reg%(8)=V:topmem% ! A0=text address (lineadd) reg%(9)=V:curline$ ! A1=buffer address reg%(10)=V:maxlinelen% ! A2=max buffer length reg%(11)=V:tabsize% ! A3=current tab size reg%(5)=showlinefeeds! ! D5=boolean show line feeds RCALL mc68000convertstring%,reg%() ENDIF ' ' Display the line of text on screen ' text(2,17,SHL(sofie%,3)+clipycoord%,LEFT$(curline$,maxlinelen%)) ' next_line(topmem%) topline%=topline%+1 ' NEXT sofie% RETURN > PROCEDURE view_clipboard ' open_window(2,130,50,429,179,"View Clipboard") IF NOT unable_to_open_window! THEN ' clipmaxpot%=117 clipycoord%=23 maxlinelen%=46 draw_box(2,15,clipycoord%-7,18+maxlinelen%*8,clipycoord%+14*8+2) draw_box(2,393,16,412,137) draw_box(2,15,141,412,153) ' topclip%=1 count_lines(clipstart%,clipsize%,cliplines%) update_clip_prop display_clip_page(topclip%) ' colour2(2,pen1%,backcol%) int2string(clipsize%) centre_text(2,"Clipboard Contains "+aimee$+" Bytes & "+STR$(cliplines%)+" Lines",429,150) ' create_gadget(2,200,159,"OKAY",gad1%()) REPEAT ' clip_prop_hit ' test_for_sleep(2) test_gadget(2,gad1%(),okay!) ' IF event_key$=CHR$(13) OR event_key$=CHR$(27) THEN okay!=TRUE ELSE IF event_key$=uparrow$ IF ie_alt! THEN topclip%=1 ELSE IF topclip%>1 topclip%=topclip%-1 ENDIF ELSE IF event_key$=dnarrow$ IF ie_alt! THEN topclip%=MAX(cliplines%-14,1) ELSE IF topclip%"Z" THEN update_clip_prop display_clip_page(topclip%) ENDIF UNTIL okay! OR abortgadget! test_gadget_keypress(2,gad1%(),okay!) close_window(2) ENDIF ' RETURN > PROCEDURE update_clip_prop ' ' Works out where the proportional gadget should be and refreshes it ' IF cliplines%>15 THEN clipproppos=(topclip%-1)/cliplines% clippropsize=MIN(15/cliplines%,1) ELSE clipproppos=0 clippropsize=1 ENDIF clipproppos=INT(clipproppos*clipmaxpot%) clippropsize=INT(clippropsize*clipmaxpot%) display_clip_prop(1) RETURN > PROCEDURE display_clip_prop(col%) ' ' displays the proportional gadget in colour COL ' IF clipproppos+clippropsize=clipmaxpot%-1 THEN clipproppos=clipproppos+1 ENDIF IF clipproppos+clippropsize>clipmaxpot% THEN clippropsize=clipmaxpot%-clipproppos ENDIF ' colour1(2,backcol%) pbox(2,397,17,408,17+clipproppos) pbox(2,397,19+clipproppos+clippropsize,408,136) colour2(2,col%,col0%) pbox(2,397,18+clipproppos,408,18+clipproppos+clippropsize) RETURN > PROCEDURE clip_prop_hit IF mouse! THEN IF event_x%>396 AND event_x%<409 AND event_y%>17 AND event_y%<135 display_clip_prop(2) check_mouse_click WHILE mouse! clipproppos=MAX(INT(event_y%-17-(clippropsize/2)),0) IF clipproppos+clippropsize>clipmaxpot% THEN clipproppos=clipmaxpot%-clippropsize ENDIF ' display_clip_prop(2) newclippos%=INT((clipproppos*cliplines%)/clipmaxpot%)+1 IF newclippos%<>topclip% THEN topclip%=newclippos% display_clip_page(topclip%) ENDIF ' test_events(2) WEND update_clip_prop ENDIF ENDIF RETURN ' ************************ CUSTOM FILE REQUESTER **************************** > PROCEDURE get_directory_list ' ' makes a list of all the files in the current directory, putting ' filenames into the array TABLE$ and filesizes into the array ENTRYSIZE ' then updates the variable NOOFFILES respectively. ' LOCAL a$,temppath$,ex%,lock%,adr%,l%,mousepressed!,diskindrive!,key$ ' nooffiles%=0 select%=0 topdir%=1 bytes%=0 dubclick!=FALSE mousepressed!=FALSE mouse!=FALSE cancel!=FALSE newdrive!=FALSE devicelist!=FALSE refresh_string(2,80,126,33,path$) ' ' If the path name begins DFx:, then check to see if there is a disk ' in the specified drive. ' diskindrive!=TRUE IF UPPER$(LEFT$(path$,2))="DF" AND MID$(path$,4,1)=":" THEN is_disk_in_drive(VAL(MID$(path$,3,1)),diskindrive!) ENDIF ' ' Do not do anything if there is not a disk in the drive ... ' IF diskindrive! THEN a$=RIGHT$(path$,1) IF a$<>"/" AND a$<>":" AND path$<>"" THEN path$=path$+"/" ENDIF is_device_mounted(path$) IF NOT diskerror! THEN file_type(path$,typeoffile%) ! ** TYPE = DIR/FILE/NOT EXIST ** colour1(2,col0%) pbox(2,17,17,322,99) set_topaz(9) style(2) colour2(2,col1%,col0%) text(2,89,60,"Reading Directory") ! ** DISPLAY A "READING" MESSAGE ** set_font(2) ' ' The actual routine is only performed if the pathname is a ' existing directory (TypeOfFile>0). ' IF typeoffile%>0 ' ' Refresh the Path gadget with the new path string ' get_path_string(path$) refresh_string(2,80,126,33,path$) ' ' Update the Bytes Free bit at the bottom of the requester ' disk_space(bytes%) int2string(bytes% DIV 1024) colour2(2,pen1%,backcol%) centre_text(2," ",367,169) centre_text(2,"Disk Space = "+aimee$+"K",367,169) ' ' Create a new pattern string with all "#?" converted to ' "*" wildcards under WB1.3 OR create a pattern token ' under WB2.0 ' create_pattern_token ' temp_pattern$=pattern$ pattern$="" caroline%=1 WHILE caroline%<=LEN(temp_pattern$) a$=MID$(temp_pattern$,caroline%,1) IF a$="#" THEN a$=MID$(temp_pattern$,caroline%+1,1) IF a$="?" THEN pattern$=pattern$+"*" caroline%=caroline%+2 ELSE pattern$=pattern$+"#" caroline%=caroline%+1 ENDIF ELSE pattern$=pattern$+a$ caroline%=caroline%+1 ENDIF WEND ' ' Start getting the directory listing ' temppath$=path$+CHR$(0) lock%=Lock(V:temppath$,-2) ! Lock the file for reading IF lock%<>0 THEN adr%=AllocMem(260,&H10001) ! Get memory for FileInfoBlock IF adr%<>0 THEN ex%=Examine(lock%,adr%) IF ex%<>0 AND LPEEK(adr%+4)<>0 THEN WHILE ExNext(lock%,adr%)<>0 AND (nooffiles%"*" AND entrysize%(nooffiles%)>=0 THEN is_same(table$(nooffiles%),same!) IF NOT same! THEN nooffiles%=nooffiles%-1 ENDIF ELSE ' ' No ".info" files to be shown in requester ' IF UPPER$(RIGHT$(table$(nooffiles%),5))=".INFO" THEN nooffiles%=nooffiles%-1 ENDIF ENDIF ' ' test for a click over one of the gadgets ' if the mouse button is being pressed ' test_events(2) IF mouse! THEN test_file_gadgets ENDIF ' ' Check for a click on the close gadget ' IF event_class%=&H200 THEN cancel!=TRUE ENDIF ' ' Allow a RETURN key to signal an OKAY gadget selection ' IF event_key$=CHR$(13) AND thefile$<>"" THEN okay!=TRUE ENDIF ' ' Check for a click on the right hand mouse button to swap between ' the device list and the current directory ' IF rmouse! THEN mousepressed!=TRUE ENDIF WEND ' ' Test for too many files (Array is only so big!) ' IF nooffiles%=maxfiles% THEN request("Can't Load All Filenames Into Requester|Current File Number Limit = "+STR$(maxfiles%)+"|(Ever Heard Of Directories?)","OH BAT'S DOS!","",x%) ENDIF ENDIF ~FreeMem(adr%,260) ENDIF ~UnLock(lock%) ENDIF pattern$="" pattern$=temp_pattern$ ' ' Refresh the display of Bytes Free and sort the directory ' listing into alphabetical order ' IF (NOT cancel!) AND (NOT mousepressed!) THEN ' QSORT table$(+) OFFSET 0,nooffiles+1,entrysize() sort_array(nooffiles%+1,TRUE,table$()) ENDIF ENDIF ' ELSE nooffiles%=-1 ENDIF ELSE nooffiles%=-2 ENDIF ' IF mousepressed! THEN nooffiles%=0 toggle_device_list rmouse!=FALSE ELSE IF NOT newdrive! THEN IF (NOT cancel!) THEN IF okay! THEN nooffiles%=0 ! NO FILES 'COS USER STOPPED LIST ELSE update_file_prop display_files(1,0,0) casepos%=1 ! MOVE ONTO THE FILE STRING GADGET recurr%=0 ! COME OUT OF RECURSIVE LOOP ENDIF ELSE nooffiles%=0 ! NO FILES 'COS USER CANCELED cancel!=TRUE ENDIF ENDIF ENDIF RETURN > PROCEDURE get_new_directory(direct$) ' ' Gets the directory listing of the input parameter, refreshes the ' Path gadget in the file requester and updates the internal path ' variable. ' path$=direct$ get_directory_list RETURN > PROCEDURE display_files(top%,cursor%,spec%) ' ' top = number of entry at top of the window ' cursor = number of entry which is currently selected (if any) ' spec = if spec>0, then update only that line of the window ' set_topaz(9) style(2) IF nooffiles%<=0 THEN colour1(2,col0%) pbox(2,17,17,322,99) recurr%=0 ENDIF ' space_na!=FALSE ' colour2(2,col1%,col0%) IF nooffiles%=0 THEN text(2,70,60,"No Directory Entries") ELSE IF nooffiles%=-1 text(2,74,60,"Device Not Mounted!") space_na!=TRUE ELSE IF nooffiles%=-2 text(2,86,60,"No Disk In Drive!") space_na!=TRUE ELSE l%=0 WHILE l%<9 IF spec%=0 OR spec%=l%+1 THEN colour1(2,col0%) pbox(2,19,18+l%*9,320,26+l%*9) IF top%<=nooffiles% THEN IF entrysize%(top%)<0 THEN colour2(2,col2%,col0%) ELSE colour2(2,col1%,col0%) ENDIF text(2,21,25+l%*9,LEFT$(table$(top%),25)) IF entrysize%(top%)>=0 THEN a$=RIGHT$(" "+STR$(entrysize%(top%)),6) ELSE IF entrysize%(top%)=-2 a$=" (DEV)" ELSE a$=" (DIR)" ENDIF text(2,259,25+l%*9,a$) IF top%=cursor% THEN xor_region(2,19,18+l%*9,320,26+l%*9) ENDIF ENDIF ENDIF top%=top%+1 l%=l%+1 WEND ENDIF ' IF select%=topdir%+1 THEN colour1(2,col3%) line(2,19,27,320,27) ENDIF set_font(2) ' IF space_na! THEN colour2(2,pen1%,backcol%) centre_text(2," Disk Space = N/A ",367,169) ENDIF ' RETURN > PROCEDURE test_file_mouse ' ' Acts upon a mouse click when in a file requester ' LOCAL dx%,dy%,oldtop% ' IF mouse! THEN dx%=event_x% dy%=event_y% ' ' >>>> TEST FOR A CLICK ON THE PROP GADGET <<<< ' IF (dx%>332 AND dx%<355) AND (dy%>25 AND dy%<91) THEN file_prop_hit ELSE ' ' >>>> TEST FOR CLICK ON UP/DOWN ARROWS <<<< ' IF (dx%>332 AND dx%<355) AND (dy%>15 AND dy%<101) THEN IF dy%<60 THEN ! XOR the arrow gadget xor_region(2,332,16,351,24) ELSE xor_region(2,332,92,351,100) ENDIF ' colour2(2,col1%,col0%) WHILE mouse! IF nooffiles%>9 THEN IF dy%<60 THEN scroll_files_up update_file_prop ELSE scroll_files_down update_file_prop ENDIF ENDIF test_events(2) WEND ' IF dy%<60 THEN ! XOR arrow to original state xor_region(2,332,16,351,24) ELSE xor_region(2,332,92,351,100) ENDIF ENDIF ENDIF ' ' >>>> TEST FOR A FILE SELECTION WITH THE MOUSE <<<< ' IF (dx%>17 AND dx%<322) AND (dy%>17 AND dy%<99) THEN oldselect%=select% dy%=(dy%-17) DIV 9 IF topdir%+dy%<=nooffiles% THEN select%=topdir%+dy% IF select%<>oldselect% THEN IF (oldselect%>=topdir%) AND (oldselect%=0 THEN thefile$=table$(select%) refresh_string(2,80,141,33,thefile$) ELSE dubclick!=TRUE ENDIF display_files(topdir%,select%,dy%+1) ELSE dubclick!=TRUE ENDIF ENDIF ENDIF ENDIF ' ' Check for a click on the right hand mouse button to swap between ' the device list and the current directory ' IF rmouse! THEN toggle_device_list ENDIF RETURN > PROCEDURE scroll_files_up IF topdir%>1 THEN topdir%=topdir%-1 ~ScrollRaster({winptr%(2)+50},0,-9,17,18,322,98) display_files(topdir%,select%,1) ~WaitTOF() ENDIF RETURN > PROCEDURE scroll_files_down IF topdir%<=(nooffiles%-9) THEN topdir%=topdir%+1 ~ScrollRaster({winptr%(2)+50},0,9,17,18,322,98) display_files(topdir%,select%,9) ~WaitTOF() ENDIF RETURN > PROCEDURE get_parent(VAR file$) LOCAL x% file$=TRIM$(file$) IF RIGHT$(file$,1)<>":" AND file$<>"" THEN IF RIGHT$(file$,1)="/" THEN file$=LEFT$(file$,LEN(file$)-1) ENDIF x%=RINSTR(file$,"/") IF x%=0 THEN x%=RINSTR(file$,":") ENDIF file$=LEFT$(file$,x%) ENDIF RETURN PROCEDURE get_file(reqno%,title$,gadget$,VAR flag%) ' ' This is the procedure which coordinates the file requester. The following ' are the functions of the 3 paramters :- ' ' REQNO = which file requester buffer to use (0..2) ' TITLE$ = the title of the requester (e.g. "Load A File") ' GADGET$ = the text used for the `Okay' gadget (e.g. "Load") ' FLAG = 0 = Cancel pressed, 1 = Okay pressed. ' ' Is the requester being called by an ARexx command? If it is ' then return immediately with the value of the command's parameter ' IF arexx_command! THEN filename$=argv$(3) split_filename(filename$,path$,thefile$) IF path$="" THEN path$=path$(reqno%) append_filename(path$,filename$,filename$) ENDIF file_type(filename$,argfiletype%) ' IF argfiletype%>=0 THEN ' IF argfiletype%>0 THEN path$(reqno%)=filename$ newdir!(reqno%)=TRUE filename$="" ENDIF ' IF thefile$<>"" THEN title$="Locate "+CHR$(34)+thefile$+CHR$(34) ENDIF ' arexx_command!=FALSE get_edword_file(reqno%,title$,gadget$) arexx_command!=TRUE IF filename$="" THEN arexx_result("No filename specified",10) ENDIF ENDIF ' ELSE ' ' Otherwise, normal operation ... ' get_edword_file(reqno%,title$,gadget$) ' ENDIF flag%=ABS(filename$<>"") RETURN > PROCEDURE get_edword_file(reqno%,title$,gadget$) ' ' This is the procedure which coordinates the file requester. The following ' are the functions of the 3 paramters :- ' ' REQNO = which file requester buffer to use (0..2) ' TITLE$ = the title of the requester (e.g. "Load A File") ' GADGET$ = the text used for the `Okay' gadget (e.g. "Load") ' LOCAL casepos%,test!,okay!,cancel!,exit% ' use_requester(reqno%) IF use_arp! THEN ' ' Use the Arp library file requester if -ARP command line option ' get_arp_file(title$) ' ELSE IF use_asl! ' ' Use the Asl library file requester if -ASL command line option ' get_asl_file(title$,gadget$) ' ELSE open_window(2,120,20,367,178,title$) IF NOT unable_to_open_window! THEN ' colour2(2,pen1%,backcol%) text(2,20,126,"Path :") text(2,20,141,"File :") text(2,106,156,"Pattern :") ' ' The main directory area ' colour2(2,col0%,col0%) pbox(2,17,17,322,99) draw_box(2,15,16,324,100) ' ' The proportional gadget ' draw_box(2,332,26,351,90) update_file_prop ' ' Up & Down scroll arrows ' up_scroll_arrow(2,335,16) dn_scroll_arrow(2,335,92) ' create_gadget(2,16,155,LEFT$(gadget$+SPACE$(6),6),okgad%()) create_gadget(2,284,155,cancel$,cancgad%()) create_gadget(2,12,103,"@"+LEFT$(drive$(0)+SPACE$(5),5),df0%()) create_gadget(2,72,103,"@"+LEFT$(drive$(1)+SPACE$(5),5),df1%()) create_gadget(2,132,103,"@"+LEFT$(drive$(2)+SPACE$(5),5),df2%()) create_gadget(2,192,103,"@"+LEFT$(drive$(3)+SPACE$(5),5),dh0%()) create_gadget(2,252,103,"@"+LEFT$(drive$(4)+SPACE$(5),5),ram%()) create_gadget(2,312,103,"@ / ",parent%()) refresh_string(2,80,126,33,path$) refresh_string(2,80,141,33,thefile$) refresh_string(2,191,156,8,pattern$) ' ' check_drives ' assign(device$) ! get the list of devices check_for_drive(drive$(0)) IF NOT drive_exist! THEN gadget_off(2,df0%()) ENDIF check_for_drive(drive$(1)) IF NOT drive_exist! THEN gadget_off(2,df1%()) ENDIF check_for_drive(drive$(2)) IF NOT drive_exist! THEN gadget_off(2,df2%()) ENDIF check_for_drive(drive$(3)) IF NOT drive_exist! THEN gadget_off(2,dh0%()) ENDIF check_for_drive(drive$(4)) IF NOT drive_exist! THEN gadget_off(2,ram%()) ENDIF ' IF nooffiles%=0 THEN newdir!=TRUE ENDIF ' dubclick!=FALSE devicelist!=FALSE casepos%=1 ! Initialise the file string gadget first select%=0 IF nodir! THEN toggle_device_list ! display device list is -NODIR option used nodir!=FALSE ELSE IF NOT newdir! display_files(topdir%,0,0) colour2(2,pen1%,backcol%) IF bytes%<>0 THEN int2string(bytes% DIV 1024) centre_text(2,"Disk Space = "+aimee$+"K",367,169) ENDIF ENDIF ' WHILE (NOT okay!) AND (NOT cancel!) AND (NOT abortgadget!) IF NOT newdir! THEN old_pattern$=pattern$ string_group(2,80,126,33,80,0,casepos%,path$,exit%) string_group(2,80,141,33,80,1,casepos%,thefile$,exit%) string_group(2,191,156,8,20,2,casepos%,pattern$,exit%) test_for_new_pattern(pattern$,old_pattern$) ENDIF ' recurr%=0 test_file_gadgets REPEAT IF newdir! THEN get_directory_list newdir!=FALSE ENDIF ' IF exit%=2 THEN ! *** WAS CANCEL SELECTED *** IF casepos%=0 THEN ! *** NEW PATH SELECTED *** get_directory_list ELSE IF casepos%=1 ! *** NEW FILENAME SELECTED *** IF TRIM$(thefile$)="" THEN cancel!=TRUE ELSE okay!=TRUE ENDIF ELSE IF casepos%=2 casepos%=1 ENDIF ELSE casepos%=(casepos%+exit%+3) MOD 3 ENDIF ' IF df0! THEN ! *** WAS DF0: SELECTED *** get_new_directory(drive$(0)) ENDIF IF df1! THEN ! *** WAS DF1: SELECTED *** get_new_directory(drive$(1)) ENDIF IF df2! THEN ! *** WAS DF2: SELECTED *** get_new_directory(drive$(2)) ENDIF IF dh0! THEN ! *** WAS DH0: SELECTED *** get_new_directory(drive$(3)) ENDIF IF ram! THEN ! *** WAS RAM: SELECTED *** get_new_directory(drive$(4)) ENDIF IF parent! THEN ! *** WAS PARENT SELECTED *** get_parent(path$) newdir!=TRUE ENDIF UNTIL recurr%<=1 OR okay! OR cancel! OR abortgadget! ' test_file_mouse ! *** TEST FOR A MOUSE CLICK *** IF dubclick! THEN IF entrysize%(select%)=-1 THEN append_filename(path$,table$(select%),path$) newdir!=TRUE ELSE IF entrysize%(select%)=-2 path$=table$(select%) newdir!=TRUE ELSE okay!=TRUE ENDIF ENDIF ' IF devicelist! THEN device_topdir%=topdir% ENDIF WEND test_gadget_keypress(2,okgad%(),okay!) test_gadget_keypress(2,cancgad%(),cancel!) ' ' Auto Suggest facility (for when file not found) ' IF okay! AND reqno%=0 THEN append_filename(path$,thefile$,filename$) auto_suggest(okay!) cancel!=NOT okay! ENDIF ' ' Make up the global variable `filename$' which holds the name of ' of the file selected (or a null string if no selection made or ' the requester was canceled). ' IF thefile$<>"" AND okay! THEN append_filename(path$,thefile$,filename$) ELSE filename$="" ENDIF ' close_window(2) ENDIF ENDIF done_requester(reqno%) ' RETURN > PROCEDURE get_arp_file(title$) ' ' Uses the Arp library requester as an alternative to the EdWord one. ' Note that the file "libs:arp.library" must be present first. ' ' LOCAL dbuffer$,fbuffer$ ' requester%=AllocMem(26,65538) ! 26 bytes are for the structure IF requester%<>0 THEN ' ' Set the initial directory and filename ... ' IF RIGHT$(path$,1)="/" THEN path$=LEFT$(path$,LEN(path$)-1) ENDIF ' dbuffer$=path$+STRING$(80,CHR$(0)) fbuffer$=thefile$+STRING$(80,CHR$(0)) title$=title$+CHR$(0) ' ' Fill the Requester structure with relevant entries ' LPOKE requester%,V:title$ LPOKE requester%+4,V:fbuffer$ LPOKE requester%+8,V:dbuffer$ LPOKE requester%+12,winptr%(0) POKE requester%+16,0 ' ' Call the FileRequest() function form arp.library ' clear_registers reg%(8)=requester% ! Put structure address in A1 reg%(14)=arpbase% ! Put arpbase address in A6 RCALL arpbase%-294,reg%() ! Call the routine at offset -294 ' ' Get the return code and selected filename ' IF reg%(0)<>0 THEN path$=CHAR{V:dbuffer$} ! Get the directory name thefile$=CHAR{V:fbuffer$} ! Get the filename append_filename(path$,thefile$,filename$) ELSE filename$="" ENDIF ' ~FreeMem(requester%,26) ENDIF ' RETURN > PROCEDURE get_asl_file(title$,gadget$) ' ' Uses the Asl library requester as an alternative to the EdWord one. ' Note that the file "libs:asl.library" must be present first. ' ' LOCAL dbuffer$,fbuffer$ ' asltaglist%=AllocMem(80,1) ' IF aslrequester%<>0 AND asltaglist%<>0 THEN ' ' Set the initial directory and filename ... ' dbuffer$=path$+STRING$(255,CHR$(0)) fbuffer$=thefile$+STRING$(255,CHR$(0)) title$=title$+CHR$(0) okgadget$=gadget$+CHR$(0) cancelgadget$=cancel$+CHR$(0) aslpattern$=pattern$+CHR$(0)+SPACE$(80) ' ' Set up the Tag List ... ' LPOKE asltaglist%,&H80080002 ! ASL_Window LPOKE asltaglist%+4,winptr%(0) LPOKE asltaglist%+8,&H80080001 ! ASL_Hail LPOKE asltaglist%+12,V:title$ LPOKE asltaglist%+16,&H80080012 ! ASL_OKText LPOKE asltaglist%+20,V:okgadget$ LPOKE asltaglist%+24,&H80080013 ! ASL_CancelText LPOKE asltaglist%+28,V:cancelgadget$ LPOKE asltaglist%+32,&H80080008 ! ASL_File LPOKE asltaglist%+36,V:fbuffer$ LPOKE asltaglist%+40,&H80080009 ! ASL_Dir LPOKE asltaglist%+44,V:dbuffer$ LPOKE asltaglist%+48,&H8008000A ! ASL_Pattern LPOKE asltaglist%+52,V:aslpattern$ LPOKE asltaglist%+56,&H80080014 ! ASL_FuncFlags (PatGad=1, SaveReq=$20) IF UPPER$(gadget$)="SAVE" THEN LPOKE asltaglist%+60,&H21 ELSE LPOKE asltaglist%+60,1 ENDIF LPOKE asltaglist%+64,0 ' ' Call the AslRequest() function form asl.library ' reg%(8)=aslrequester% ! A0 = file structure address reg%(9)=asltaglist% ! A1 = tag list address reg%(14)=aslbase% ! A6 = asl.libray base address RCALL aslbase%-&H3C,reg%() ! Call the AslRequest() routine ' ' Get the return code and selected filename ' pattern$=CHAR{{aslrequester%+52}} IF reg%(0)<>0 THEN thefile$=CHAR{{aslrequester%+4}} ! Get the filename path$=CHAR{{aslrequester%+8}} ! Get the directory name IF thefile$="" THEN filename$="" ELSE append_filename(path$,thefile$,filename$) ENDIF ELSE filename$="" ENDIF ' ELSE use_asl!=FALSE ENDIF ' IF asltaglist%<>0 THEN ~FreeMem(asltaglist%,80) ENDIF ' RETURN > PROCEDURE allocate_asl ' ' Opens the asl.library and allocates a buffer for a File Requester ' aimee$="asl.library"+CHR$(0) aslbase%=OpenLibrary(V:aimee$,37) IF aslbase%=0 THEN use_asl!=FALSE ELSE ' ' Call the AllocFileRequest() routine ' reg%(14)=aslbase% ! A6 = asl.library base address RCALL aslbase%-&H1E,reg%() ! Call the AllocFileRequest() routine aslrequester%=reg%(0) ' IF aslrequester%=0 THEN ~CloseLibrary(aslbase%) aslbase%=0 use_asl!=FALSE ELSE use_arp!=FALSE ENDIF ENDIF RETURN > PROCEDURE deallocate_asl ' ' Deallocates an asl.library file requester and closes the library ' IF aslbase%<>0 THEN IF aslrequester%<>0 THEN reg%(8)=aslrequester% ! A0 = The File Requester struct. reg%(14)=aslbase% ! A6 = asl.library base address RCALL aslbase%-&H24,reg%() ! Call the FreeFileRequest() routine ENDIF ~CloseLibrary(aslbase%) ENDIF RETURN > PROCEDURE file_type(file$,VAR entry%) ' ' Checks to see what kind of entry the specifies filename, FILE$, is. ' Where, ENTRY, will be returned with one of the following 4 values :- ' ' ENTRY = 0 if not exists ' = +1 if directory ' = -1 if file ' LOCAL tempfile$,lock%,x%,adr%,numb% ' entry%=0 tempfile$=file$+CHR$(0) ' lock%=Lock(V:tempfile$,-2) IF lock%<>0 THEN adr%=AllocMem(260,&H10001) IF adr%<>0 THEN x%=Examine(lock%,adr%) IF x%<>0 THEN numb%=LPEEK(adr%+4) entry%=SGN(numb%) ENDIF ~FreeMem(adr%,260) ENDIF ~UnLock(lock%) ENDIF RETURN > PROCEDURE update_file_prop ' ' Works out where the proportional gadget should be and refreshes it ' IF nooffiles%>9 THEN fproppos=(topdir%-1)/nooffiles% fpropsize=MIN(9/nooffiles%,1) ELSE fproppos=0 fpropsize=1 ENDIF fproppos=INT(fproppos*fmaxpot%) fpropsize=INT(fpropsize*fmaxpot%) display_file_prop(1) RETURN > PROCEDURE display_file_prop(col%) ' ' displays the proportional gadget in colour COL ' IF fproppos+fpropsize=fmaxpot%-1 THEN fproppos=fproppos+1 ENDIF fpropsize=MIN(fmaxpot%-fproppos,fpropsize) ' colour1(2,backcol%) pbox(2,336,27,347,27+fproppos) pbox(2,336,29+fproppos+fpropsize,347,89) colour2(2,col%,col0%) pbox(2,336,28+fproppos,347,28+fproppos+fpropsize) RETURN > PROCEDURE file_prop_hit IF nooffiles%>=9 THEN oldpos=INT(((topdir%-1)/nooffiles%)*fmaxpot%) fpropsize=MIN(9/nooffiles%,1) ELSE oldpos=0 fpropsize=1 ENDIF fpropsize=INT(fpropsize*fmaxpot%) refresh!=FALSE y%=event_y%-28 ' py%=y%-oldpos IF py%<0 THEN topdir%=MAX(topdir%-9,1) display_files(topdir%,select%,0) update_file_prop ELSE IF py%>fpropsize topdir%=MIN(topdir%+9,nooffiles%-8) display_files(topdir%,select%,0) update_file_prop ELSE display_file_prop(2) check_mouse_click WHILE mouse! newpos=MAX(INT(event_y%-28-(fpropsize/2)),0) IF newpos+fpropsize>fmaxpot% THEN newpos=fmaxpot%-fpropsize ENDIF ' IF newpos<>oldpos THEN fproppos=newpos display_file_prop(2) refresh!=TRUE ENDIF oldpos=newpos ' newtopdir%=INT((oldpos*nooffiles%)/fmaxpot%)+1 IF newtopdir%>topdir% THEN scroll_files_down ELSE IF newtopdir%topdir% THEN topdir%=newtopdir% display_files(topdir%,select%,0) ENDIF ENDIF ENDIF RETURN > PROCEDURE test_file_gadgets ' ' Routine which tests to see if the user has clicked on any of the ' file requester gadgets. The reason for put this but in a seperate ' procedure (apart from being structured - yuk!). It is called by the ' GetFile and the GetDirList procedures so that it is possible to ' click on the gadgets even while the program is listing a directory. ' test_gadget(2,cancgad%(),cancel!) ! *** WAS CANCEL SELECTED *** test_gadget(2,okgad%(),okay!) ! *** WAS OKAY SELECTED *** test_gadget(2,df0%(),df0!) ! *** WAS DF0: SELECTED *** test_gadget(2,df1%(),df1!) ! *** WAS DF1: SELECTED *** test_gadget(2,df2%(),df2!) ! *** WAS DF2: SELECTED *** test_gadget(2,dh0%(),dh0!) ! *** WAS DH0: SELECTED *** test_gadget(2,ram%(),ram!) ! *** WAS RAM: SELECTED *** test_gadget(2,parent%(),parent!) ! *** WAS PARENT SELECTED *** ' IF RIGHT$(path$,1)=":" OR path$="" ! Check to see if dir has parent parent!=FALSE ENDIF ' IF df0! OR df1! OR df2! OR dh0! OR ram! OR parent! THEN newdrive!=TRUE recurr%=recurr%+1 ELSE newdrive!=FALSE recurr%=0 ENDIF ' IF thefile$="" OR parent! THEN okay!=FALSE ENDIF RETURN > PROCEDURE toggle_device_list ' ' Controls the switching of modes for the file requester, between ' ' 1) List of files/dirs in current directory ' 2) List of mounted devices ' LOCAL tempcopy%,dev$,curdev%,curdev$ ' colour1(2,col0%) pbox(2,17,17,322,99) ' IF devicelist! THEN nooffiles%=temp_nooffiles% select%=temp_select% topdir%=temp_topdir% path$=temp_path$ dubclick!=FALSE devicelist!=FALSE ' FOR tempcopy%=1 TO nooffiles% table$(tempcopy%)=temptable$(tempcopy%) entrysize%(tempcopy%)=tempentrysize%(tempcopy%) NEXT tempcopy% ELSE temp_nooffiles%=nooffiles% temp_select%=select% temp_topdir%=topdir% temp_path$=path$ dubclick!=FALSE devicelist!=TRUE ' FOR tempcopy%=1 TO nooffiles% temptable$(tempcopy%)=table$(tempcopy%) tempentrysize%(tempcopy%)=entrysize%(tempcopy%) NEXT tempcopy% ' nooffiles%=0 curdev$="" assign(dev$) ' FOR tempcopy%=1 TO LEN(dev$) a$=MID$(dev$,tempcopy%,1) IF a$=":" THEN nooffiles%=nooffiles%+1 table$(nooffiles%)=curdev$+":" entrysize%(nooffiles%)=-2 curdev$="" ELSE curdev$=curdev$+a$ ENDIF NEXT tempcopy% QSORT table$(+) OFFSET 0,nooffiles%+1 ' topdir%=MAX(MIN(device_topdir%,nooffiles%-8),1) select%=0 ENDIF ' update_file_prop display_files(topdir%,select%,0) ' WHILE MOUSEK<>0 WEND RETURN > PROCEDURE test_for_new_pattern(VAR pattern$,old_pattern$) LOCAL pos% ' IF NOT pcoff! THEN pattern$=UPPER$(pattern$) ENDIF IF pattern$="" THEN pattern$="#?" ENDIF ' ' >>>>>> REMOVE ANY EXTRANIOUS WILDCARDS FROM THE PATTERN <<<<<< ' WHILE INSTR(pattern$,"**")>0 OR INSTR(pattern$,"*?")>0 pos%=INSTR(pattern$,"**") IF pos%=0 THEN pos%=INSTR(pattern$,"*?") ENDIF pattern$=LEFT$(pattern$,pos%)+RIGHT$(pattern$,LEN(pattern$)-pos%-1) WEND ' WHILE INSTR(pattern$,"#?#?")>0 OR INSTR(pattern$,"#??")>0 pos%=INSTR(pattern$,"#?#?") IF pos%=0 THEN pos%=INSTR(pattern$,"#??") ENDIF pattern$=LEFT$(pattern$,pos%+1)+RIGHT$(pattern$,LEN(pattern$)-pos%-3) WEND ' ' >>>>> REFRESH THE DISPLAY OF THE PATTERN ON THE FILE REQUESTER <<<<< ' refresh_string(2,191,156,8,pattern$) ' ' >>>>> GET A NEW LISTING IF THE PATTERN HAS BEEN CHANGED <<<<< ' IF pattern$<>old_pattern$ THEN get_directory_list casepos%=1 exit%=0 ENDIF RETURN > PROCEDURE is_same_pcon(name$,pattern$,VAR same!) ' ' Procedure : IsSame ' Author : Martin Reddy ' Date : 24/12/91 ' Purpose : Implements a pattern matching algorithm to see if a text string ' is equivalent to a rule pattern containing wildcards. The two ' standard wildcards are available :- ' * = loads of any characters (case independant) ' ? = any one character ( "" "" ) ' ~ = the NOT of the pattern ' e.g. "Hello.pas" matches the pattern "*.pas" or "*.*" etc. ' LOCAL posname%,pospattern%,charname$,pattern1$,pattern2$,loop%,char$ ' ' >>>>> CHECK FOR THE NOT (~) WILDCARD <<<<< ' IF LEFT$(pattern$,1)="~" THEN pattern$=RIGHT$(pattern$,LEN(pattern$)-1) not_function!=TRUE ELSE not_function!=FALSE ENDIF ' ' >>>>>> ZERO-TERMINATE THE TWO STRINGS <<<<<< ' LET name$=UPPER$(name$)+CHR$(0) LET pattern$=pattern$+CHR$(0) ' same!=TRUE posname%=1 pospattern%=1 WHILE posname%<=LEN(name$) AND same! ' ' >>>>>> GET THE NEXT CHARACTER IN EACH OF THE TWO STRINGS <<<<<< ' charname$=MID$(name$,posname%,1) pattern1$=UPPER$(MID$(pattern$,pospattern%,1)) ' IF pattern1$="*" THEN ' ' >>>>>> THE TESTING BIT FOR THE "*" WILDCARD <<<<<< ' pattern2$="" FOR loop%=pospattern%+1 TO LEN(pattern$) char$=UPPER$(MID$(pattern$,loop%,1)) EXIT IF char$="*" OR char$="?" pattern2$=pattern2$+char$ NEXT loop% ' IF pattern2$<>"" THEN nextchar%=INSTR(name$,pattern2$,posname%) IF nextchar%=0 THEN same!=FALSE ELSE posname%=nextchar% pospattern%=pospattern%+1 ENDIF ELSE posname%=LEN(name$)+1 ENDIF ELSE ' ' >>>>>> THE TWO STRINGS ARE DIFFERENT IF THEIR SIZES ARE DIFFERENT <<<<<< ' IF (posname%=LEN(name$)) AND (pospattern%>>>>> TEST THE CHARACTER AGAINST A "?" WILDCARD OR LETTER <<<<<< ' IF pattern1$<>"?" THEN IF charname$<>pattern1$ THEN same!=FALSE ENDIF ENDIF posname%=posname%+1 pospattern%=pospattern%+1 ENDIF WEND ' ' >>>>> Account for the NOT (~) wildcard <<<<< ' IF not_function! THEN same!=NOT same! ENDIF RETURN > PROCEDURE is_same_pcoff(name$,pattern$,VAR same!) ' ' Procedure : IsSame ' Author : Martin Reddy ' Date : 24/12/91 ' Purpose : Implements a pattern matching algorithm to see if a text string ' is equivalent to a rule pattern containing wildcards. The two ' standard wildcards are available :- ' * = loads of any characters (case independant) ' ? = any one character ( "" "" ) ' ~ = the NOT of the pattern ' e.g. "Hello.pas" matches the pattern "*.pas" or "*.*" etc. ' ' *** Case-Sensitive version of Is_Same() *** ' LOCAL posname%,pospattern%,charname$,pattern1$,pattern2$,loop%,char$ ' ' >>>>> CHECK FOR THE NOT (~) WILDCARD <<<<< ' IF LEFT$(pattern$,1)="~" THEN pattern$=RIGHT$(pattern$,LEN(pattern$)-1) not_function!=TRUE ELSE not_function!=FALSE ENDIF ' ' >>>>>> ZERO-TERMINATE THE TWO STRINGS <<<<<< ' LET name$=name$+CHR$(0) LET pattern$=pattern$+CHR$(0) ' same!=TRUE posname%=1 pospattern%=1 WHILE posname%<=LEN(name$) AND same! ' ' >>>>>> GET THE NEXT CHARACTER IN EACH OF THE TWO STRINGS <<<<<< ' charname$=MID$(name$,posname%,1) pattern1$=MID$(pattern$,pospattern%,1) ' IF pattern1$="*" THEN ' ' >>>>>> THE TESTING BIT FOR THE "*" WILDCARD <<<<<< ' pattern2$="" FOR loop%=pospattern%+1 TO LEN(pattern$) char$=MID$(pattern$,loop%,1) EXIT IF char$="*" OR char$="?" pattern2$=pattern2$+char$ NEXT loop% ' IF pattern2$<>"" THEN nextchar%=INSTR(name$,pattern2$,posname%) IF nextchar%=0 THEN same!=FALSE ELSE posname%=nextchar% pospattern%=pospattern%+1 ENDIF ELSE posname%=LEN(name$)+1 ENDIF ELSE ' ' >>>>>> THE TWO STRINGS ARE DIFFERENT IF THEIR SIZES ARE DIFFERENT <<<<<< ' IF (posname%=LEN(name$)) AND (pospattern%>>>>> TEST THE CHARACTER AGAINST A "?" WILDCARD OR LETTER <<<<<< ' IF pattern1$<>"?" THEN IF charname$<>pattern1$ THEN same!=FALSE ENDIF ENDIF posname%=posname%+1 pospattern%=pospattern%+1 ENDIF WEND ' ' >>>>> Account for the NOT (~) wildcard <<<<< ' IF not_function! THEN same!=NOT same! ENDIF RETURN > PROCEDURE dos_is_same_pcon(name$,VAR same!) ' ' Uses WorkBench 2.0 function MatchPatternNoCase() to check ' if a file matches the current pattern token (produced by ' the create_pattern_token procedure) ' LET name$=name$+CHR$(0) reg%(0)=0 reg%(1)=pattern_token% reg%(2)=V:name$ reg%(14)=_DosBase RCALL _DosBase-972,reg%() same!=(reg%(0)<>0) RETURN > PROCEDURE dos_is_same_pcoff(name$,VAR same!) ' ' Uses WorkBench 2.0 function MatchPattern() to check ' if a file matches the current pattern token (produced by ' the create_pattern_token procedure) ' LET name$=name$+CHR$(0) reg%(0)=0 reg%(1)=pattern_token% reg%(2)=V:name$ reg%(14)=_DosBase RCALL _DosBase-846,reg%() same!=(reg%(0)<>0) RETURN > PROCEDURE is_same(name$,VAR same!) ' ' Implements the appropriate pattern matchine algorithm ' depending upon whether WB2.0 or not, or case dependent or not. ' IF workbench_2.0! THEN IF pcoff! THEN dos_is_same_pcoff(name$,same!) ELSE dos_is_same_pcon(name$,same!) ENDIF ELSE IF pcoff! THEN is_same_pcoff(name$,pattern$,same!) ELSE is_same_pcon(name$,pattern$,same!) ENDIF ENDIF RETURN > PROCEDURE create_pattern_token ' ' Creats a pattern-matching token for use by the WB2.0 functions ' MatchPattern() or MatchPatternNoCase() ' INLINE pattern_token%,200 ' IF workbench_2.0! THEN temppat$=pattern$+CHR$(0) reg%(1)=V:temppat$ ! Null terminated pattern string reg%(2)=pattern_token% ! Pointer to token buffer reg%(3)=200 ! Size of token buffer reg%(14)=_DosBase ' IF pcoff! THEN RCALL _DosBase-&H348,reg%() ! ParsePattern() (Case Dep) ELSE RCALL _DosBase-&H3C6,reg%() ! ParsePatternNoCase() (Case Indep) ENDIF ENDIF RETURN > PROCEDURE check_for_drive(thedrive$) ' ' This procedure checks to see what drives the user has access to. ' This is done so that we can ghost any gadgets for DH5: or DF9: if ' he/she/it doesn't have these drives. If I'm feeling in a good mood ' after I've written this documentation I might even make it so that ' if the user doesn't have DF1: then it is replaced by something which ' he does have - but wait a sec ... that would be user friendly wouldn't ' it ... can't have any of that !!! ' ' LOCAL x% ' drive_exist!=TRUE x%=INSTR(thedrive$,":") IF x%<>0 THEN thedrive$=LEFT$(thedrive$,x%) IF INSTR(UPPER$(device$),UPPER$(thedrive$))=0 THEN drive_exist!=FALSE ENDIF ELSE ENDIF RETURN > PROCEDURE use_requester(numb%) ' ' EdWord has three different file requester buffers (so that e.g. the file ' requester for loading can be in a different directory than that for ' saving.). This routine switches in one of these banks of data (0..2) ' By default, I have used buffer 0 for load operations, buffer 1 for save ' operations and buffer 2 for anything else (e.g. delete, rename etc.) ' ' If this is the first time requester has been opened, then use the buffer ' from a requester which has already been used (if there is one). ' ' get the requester buffer data ' FOR tracy%=0 TO maxfiles% table$(tracy%)=reqname$(tracy%,numb%) entrysize%(tracy%)=reqsize%(tracy%,numb%) NEXT tracy% newdir!=newdir!(numb%) thefile$=thefile$(numb%) path$=path$(numb%) nooffiles%=nooffiles%(numb%) topdir%=topdir%(numb%) bytes%=bytesfree%(numb%) pattern$=pattern$(numb%) ' IF path$="" THEN path$=defaultdir$ newdir!=TRUE ENDIF ' ' If loading, then clear the filename, if saving then filename=current name ' IF numb%=0 OR numb%=2 THEN thefile$="" ELSE split_filename(curfilename$,dummy$,thefile$) ENDIF RETURN > PROCEDURE done_requester(numb%) ' ' This routine saves the current file requester data into of the three ' memory buffer (0..2) so that its position can be remembered the next ' time round. It also saves the current requester data into any other ' buffer which has the same pathname. ' FOR eileen%=0 TO maxreqs% IF (UPPER$(path$(eileen%))=UPPER$(path$) AND pattern$(eileen%)=pattern$) OR eileen%=numb% OR firstdir! THEN FOR tracy%=0 TO maxfiles% reqname$(tracy%,eileen%)=table$(tracy%) reqsize%(tracy%,eileen%)=entrysize%(tracy%) NEXT tracy% ' IF eileen%=numb% OR firstdir! THEN thefile$(eileen%)=thefile$ pattern$(eileen%)=pattern$ topdir%(eileen%)=topdir% path$(eileen%)=path$ ENDIF nooffiles%(eileen%)=nooffiles% newdir!(eileen%)=newdir! bytesfree%(eileen%)=bytes% ' ENDIF NEXT eileen% firstdir!=FALSE RETURN > PROCEDURE new_dir(numb%) ' ' If the current directory needs updating, then see ' if there are any other rquester buffers with the ' same path name because they will need updating ' also. ' newdir!(numb%)=TRUE ' FOR tracy%=0 TO maxreqs% IF UPPER$(path$(tracy%))=UPPER$(path$(numb%)) THEN newdir!(tracy%)=TRUE ENDIF NEXT tracy% RETURN > PROCEDURE auto_suggest(VAR result!) ' ' AUTOSUGGEST : If a file does not exist, then EdWord suggests an alternative ' result!=TRUE file_type(filename$,exists%) IF exists%>=0 THEN ' ' Search for the closest filename to the one entered ' loop%=1 test$=TRIM$(UPPER$(thefile$)) WHILE (loop%<=nooffiles%) AND ((entrysize%(loop%)<0) OR (UPPER$(table$(loop%))0) IF result! THEN thefile$=clare$ ENDIF ELSE ' ' otherwise just bug out and tell user file not exist ' append_filename(path$,thefile$,jody$) inform("File Does Not Exist!|"+CHR$(34)+jody$+CHR$(34)+"|Cannot Complete Operation.") result!=FALSE ENDIF ENDIF RETURN ' ***************************** DISK ROUTINES ******************************* > PROCEDURE open_file ' ' The procedure which lets the user load a new file into the editor. This is ' the routine which is called when the user selects Open from the menus. ' It first checks to see if the user wants to save any changes, then it ' proceeds which a file requester and loads the selected file. ' LOCAL status%,lock% ' get_file(0,"Load A Text File","LOAD",status%) IF status%<>0 AND filename$<>"" THEN confirm_new_file("FORGET IT") @load_data ENDIF RETURN > PROCEDURE load_data ' ' Loads the file called FILENAME$ into memory starting at address DOCSTART. ' The file size is returned in NOOFCHARS and a new buffer size will be ' allocated if the file will not fit in the previous one. ' LOCAL memoryerror!,playspace% memoryerror!=FALSE quick_refresh!=TRUE playspace%=15*1024 ! xtra memory grabed (15K) ' message("Loading ...") set_pointer(1) diskerror!=FALSE file_type(filename$,exists%) IF exists%<0 THEN file_size(filename$,length%) IF length%>memorysize%-memlow% THEN IF length%>AvailMem(&H20000)+memorysize%+playspace% THEN inform("Not Enough Memory To Load Document !") memoryerror!=TRUE ELSE oldmemsize%=memorysize% memorysize%=length%+playspace% new_memory_size(oldmemsize%,FALSE) ENDIF ENDIF ' IF NOT memoryerror! THEN clear_screen dosfile$=filename$+CHR$(0) lock%=Open(V:dosfile$,mode_old%) length%=Read(lock%,docstart%,length%) ~Close(lock%) IF length%<0 THEN inform("Error Encountered During Load Operation!|Cannot Load "+CHR$(34)+filename$+CHR$(34)) reset_position ELSE curradd%=docstart% lineadd%=docstart% topadd%=docstart% curline%=1 indent%=0 cursorx%=0 cursory%=0 IF length%=0 THEN inform("Attention : File Is Empty!") ENDIF IF PEEK(docstart%+length%-1)<>lf% THEN ! Put a line feed at the EOF POKE docstart%+length%,lf% ! If there is not one already length%=length%+1 false_eof!=TRUE ELSE false_eof!=FALSE ENDIF noofchars%=length% @decrunch_powerpacker ! decrunch if PowerPacker curfilename$=filename$ count_lines(docstart%,noofchars%,nooflines%) block_off ! will refresh screen window_title(0,"") update_prop update_column update_line IF NOT arexx_command! set_global_case ENDIF lineupdated!=FALSE docupdated!=FALSE make_undo_string thefile$(1)=thefile$ ! Save requester filename ENDIF ENDIF ELSE IF exists%>0 inform("Object Is A Directory, Not A File!|Cannot Load "+CHR$(34)+filename$+CHR$(34)) ELSE diskerror!=TRUE ENDIF ' IF diskerror! THEN file_not_found(filename$) ENDIF set_pointer(0) message("") quick_refresh!=FALSE ignore_messages last_time_save%=TIMER RETURN > PROCEDURE find_file ' ' An ARexx only procedure - searches docs in memory for a file, ' if not found then attempts to load it in, if not found, then ' user is given a file requester to find it. ' LOCAL found! ' get_filename(argv$(3),a$) backup_curr_doc found!=FALSE FOR jody%=0 TO noofdocs%-1 get_filename(curfilename$(jody%),b$) IF b$=a$ THEN found!=TRUE IF jody%<>curr_docno% THEN activate_doc(jody%) refresh_multidocs ENDIF ENDIF EXIT IF found! NEXT jody% ' IF NOT found! THEN create_doc open_file IF noofchars%<=1 THEN @remove_doc ENDIF ENDIF ' RETURN > PROCEDURE revert IF curfilename$="" THEN inform("Cannot Revert To Last Saved Version!|File Has Not Been Saved Yet.") ELSE IF (NOT docupdated!) AND (NOT lineupdated!) THEN inform("You Have Not Modified The Current|File Since You Last Saved It!") ELSE request("Do You Really Wish To Revert To|The Last Saved Version Of This File?","REVERT","CANCEL",x%) IF x%<>0 THEN filename$=curfilename$ @load_data ENDIF ENDIF ENDIF RETURN > PROCEDURE erase_file ' ' Will delete a file or directory on disk. The routine will first remove ' any delete protection which has been set for the file so that the ' operation is wuite powerful. ' LOCAL store$,status%,exist%,dosname$ oldpath$=path$ oldfile$=thefile$ get_file(2,"Delete A File","DELETE",status%) IF status%<>0 THEN diskerror!=FALSE file_type(filename$,exists%) IF exists%<0 THEN request("Please Confirm Deletion of file|"+CHR$(34)+filename$+CHR$(34),"DELETE IT",cancel$,x%) IF x%<>0 THEN dosname$=filename$+CHR$(0) ~SetProtection(V:dosname$,0) ! set RWED flags status%=DeleteFile(V:dosname$) IF status%=0 THEN inform("Could Not Delete File / Directory") ELSE new_dir(2) ENDIF ENDIF thefile$="" ELSE file_not_found(filename$) ENDIF ENDIF path$=oldpath$ thefile$=oldfile$ RETURN > PROCEDURE rename_file ' ' Used to rename a file or directory on disk ' LOCAL store$,dosname1$,dosname2$,cancel! oldpath$=path$ oldfile$=thefile$ get_file(2,"Rename A File","RENAME",status%) IF status%<>0 THEN diskerror!=FALSE file_type(filename$,exists%) IF exists%<0 THEN get_duplicate(filename$,newname$) IF newname$<>"" THEN dosname1$=filename$+CHR$(0) dosname2$=newname$+CHR$(0) cancel!=FALSE IF EXIST(newname$) THEN request("Target File Already Exists!","OVERWRITE IT","FORGET IT",x%) IF x%=0 THEN cancel!=TRUE ELSE ~DeleteFile(V:dosname2$) ENDIF ENDIF ' IF NOT cancel! THEN IF Rename(V:dosname1$,V:dosname2$)=0 THEN inform("Unable To Rename File !") ELSE new_dir(2) ENDIF thefile$="" ENDIF ENDIF ELSE file_not_found(filename$) ENDIF ENDIF path$=oldpath$ thefile$=oldfile$ RETURN > PROCEDURE save_as ' ' Allows the user to specify the filename of the current document and ' then to save the document under that name. ' LOCAL status% get_file(1,"Save A Text File","SAVE",status%) IF status%<>0 AND filename$<>"" THEN is_device_mounted(filename$) IF NOT diskerror! THEN replace_requester(filename$,replace!) IF replace! THEN curfilename$=filename$ docupdated!=TRUE @save_file(FALSE) ENDIF ELSE inform("Unable To Save File|Device Not Mounted!") ENDIF ENDIF RETURN > PROCEDURE save_file(is_timed_save!) ' ' Saves the text in memory under the current filename. If backups have ' been selected, then the old file is backed up first. ' IF curfilename$="" THEN @save_as ELSE IF docupdated! OR lineupdated! THEN message("Saving ...") set_pointer(1) cursor_off free_abyss make_backup dosfile$=curfilename$+CHR$(0) lock%=Open(V:dosfile$,mode_new%) IF lock%<>0 THEN ~Write(lock%,docstart%,noofchars%+false_eof!) ~Close(lock%) @save_icon new_dir(1) lineupdated!=FALSE docupdated!=FALSE ' IF (NOT is_timed_save!) AND (timed_save!) THEN tempfilename$=curfilename$+".SAVE" IF EXIST(tempfilename$) THEN tempfilename$=tempfilename$+CHR$(0) status%=DeleteFile(V:tempfilename$) IF status%=0 THEN inform("Could Not Delete Old Time Saved Backup!") ENDIF ENDIF ENDIF ' ELSE inform("Cannot Save File|Possibly Protected!") ENDIF cursor_on set_pointer(0) message("") ELSE request("No Updates Made To Document|File Not Saved !","JUST TESTING","",x%) ENDIF ENDIF last_time_save%=TIMER RETURN > PROCEDURE save_icon ' ' Saves an icon for the current file (if the user has selected that ' he/she/it wants icons saved via the preferences window). An error ' message is displayed if any difficulties were encountered. ' LOCAL iconname$,lock% ' INLINE icon_data%,400 IF saveicon! THEN ' ' Don't save an icon if user is actually editting a ".info" file ' IF UPPER$(RIGHT$(curfilename$,5))<>".INFO" THEN ' icon_found!=FALSE IF env_mounted! THEN iconname$="ENV:EdWord/EdWordIcon.info"+CHR$(0) lock2%=Open(V:iconname$,mode_old%) IF lock2%<>0 THEN ' OPEN "I",#1,iconname$ icon_len%=LOF(#1) CLOSE #1 ' icon_mem%=AllocMem(icon_len%,1) IF icon_mem%<>0 THEN ~Read(lock2%,icon_mem%,icon_len%) ' iconname$=curfilename$+".info"+CHR$(0) lock%=Open(V:iconname$,mode_new%) IF lock%<>0 THEN ~Write(lock%,icon_mem%,icon_len%) ~Close(lock%) ELSE inform("Could Not Save Icon!") ENDIF icon_found!=TRUE ~FreeMem(icon_mem%,icon_len%) ELSE inform("Cannot Save Custom Icon|Not Enough Memory!|Using Default Icon") ENDIF ~Close(lock2%) ENDIF ENDIF ' IF NOT icon_found! THEN iconname$=curfilename$+".info"+CHR$(0) lock%=Open(V:iconname$,mode_new%) IF lock%<>0 THEN ~Write(lock%,icon_data%,420) ~Close(lock%) ELSE inform("Could Not Save Icon!") ENDIF ENDIF ' ENDIF ENDIF RETURN > PROCEDURE time_save ' IF TIMER>(last_time_save%+timed_mins%*12000) AND timed_save! THEN IF docupdated! OR lineupdated! THEN ' last_docupdated!=docupdated! last_lineupdated!=lineupdated! ' prevfilename$=curfilename$ IF curfilename$="" THEN curfilename$="EdWord.SAVE" ELSE IF timed_ext! curfilename$=curfilename$+".SAVE" ENDIF @save_file(TRUE) curfilename$=prevfilename$ ' IF timed_ext! OR curfilename$="" THEN docupdated!=last_docupdated! lineupdated!=last_lineupdated! ELSE docupdated!=FALSE lineupdated!=FALSE ENDIF ' message("") ENDIF last_time_save%=TIMER ENDIF RETURN > PROCEDURE write_block ' ' Saves the current clipboard into a file on disk. ' LOCAL size%,lock%,status%,oldpath$,oldfile$ IF blockcopied! THEN oldpath$=path$ oldfile$=thefile$ get_file(2,"Write Block To File","WRITE",status%) IF status%<>0 THEN diskerror!=FALSE replace_requester(filename$,replace!) IF replace! THEN message("Writing Block ...") set_pointer(1) size%=blockend%-blockstart% dosfile$=filename$+CHR$(0) lock%=Open(V:dosfile$,mode_new%) IF lock%<>0 THEN ~Write(lock%,clipstart%,clipsize%) ~Close(lock%) new_dir(2) ELSE diskerror!=TRUE ENDIF ignore_messages set_pointer(0) message("") ENDIF ENDIF ' IF diskerror! THEN inform("Unable To Store Text Block !") ENDIF ' path$=oldpath$ thefile$=oldfile$ ENDIF RETURN > PROCEDURE insert_file ' ' Reads a file from disk an inserts it into the document at the current ' cursor position. ' LOCAL status%,size%,lock%,oldpath$,oldfile$ ' quick_refresh!=TRUE oldpath$=path$ oldfile$=thefile$ get_file(2,"Insert File Into Document","INSERT",status%) IF status%<>0 AND filename$<>"" THEN diskerror!=FALSE file_type(filename$,exist%) IF exist%<0 THEN file_size(filename$,size%) IF size%>0 THEN IF noofchars%+size%+memlow%>memorysize% THEN memory_alert ELSE message("Reading Block ...") set_pointer(1) free_abyss BMOVE lineadd%,lineadd%+size%,docstart%+noofchars%-lineadd% ' dosname$=filename$+CHR$(0) lock%=Open(V:dosname$,mode_old%) actualsize%=Read(lock%,lineadd%,size%) ~Close(lock%) ' ' Check to see that numb of bytes read = file size ' (primarily for the CrossDOS "TxFilter" function) ' IF actualsize% PROCEDURE make_backup ' ' If the current file has been saved, then this procedure will rename ' this file with a ".BAK" extension. Used before saving new data so ' that the old file is `backed up'. If there is already a backup file ' with the required name, then that is deleted first otherwise the ' rename operation would fail. No backup will be performed if the ' current filename has a ".BAK" extension. ' LOCAL backupfile$,dosfile$,exist%,status% IF backups! THEN backupfile$=curfilename$ IF INSTR(backupfile$,".")>1 THEN backupfile$=LEFT$(backupfile$,RINSTR(backupfile$,".")-1)+".BAK" ELSE backupfile$=backupfile$+".BAK" ENDIF ' file_type(curfilename$,exist%) IF UPPER$(backupfile$)<>UPPER$(curfilename$) AND exist% THEN file_type(backupfile$,exist%) backupfile$=backupfile$+CHR$(0) IF exist%<0 THEN ! Delete old backup file first ~SetProtection(V:backupfile$,0) ~DeleteFile(V:backupfile$) ENDIF dosfile$=curfilename$+CHR$(0) status%=Rename(V:dosfile$,V:backupfile$) IF status%=0 THEN inform("Unable To Save Backup File!") ENDIF ENDIF ENDIF RETURN > PROCEDURE file_size(file$,VAR size%) IF EXIST(file$) AND file$<>"" OPEN "I",#2,file$ size%=LOF(#2) CLOSE #2 ELSE size%=0 ENDIF RETURN > PROCEDURE disk_space(VAR size%) ' ' This procedure will calculate the size of disk space free on the disk ' defined by the string, PATH$. The size is calculated by a call to the ' Info() function in the dos.library to find out the total number of ' blocks (offset 12) and the used number of blocks (offset 16). It is ' then a simple matter of subtracting the two and multiplying by the ' number of bytes in one block (512) ' LOCAL file$,filelock%,fileinfo% ' size%=0 diskerror!=FALSE file$=path$+CHR$(0) filelock%=Lock(V:file$,-2) IF filelock%<>0 THEN fileinfo%=AllocMem(260,1) IF fileinfo%<>0 THEN temp%=Info(filelock%,fileinfo%) size%=(LPEEK(fileinfo%+12)-LPEEK(fileinfo%+16))*512 ~FreeMem(fileinfo%,260) ENDIF ~UnLock(filelock%) ENDIF ' ' If the file is on the RAM: disk, then the size will equal 0. Instead ' of this, I will convert it the amount of memory available in the ' system as this will be a pretty good estimate of the bytes free in ' the RAM: disk. ' IF size%=0 THEN size%=AvailMem(0) ENDIF RETURN > PROCEDURE fexpandlock(VAR lock%,directory$) ' ' Takes an AmigaDOS BPTR file lock and finds the full pathname for that lock ' N.B. Lock is automatically UnLocked by this routine ' LOCAL templock%,currlev%,fileinfo% ' diskerror!=FALSE ! a global flag set when cannot lock device currlev%=0 ! current directory nesting level ' IF lock%<>0 THEN fileinfo%=AllocMem(260,1) ! Try to get memory for a FileInfoBlock IF fileinfo%<>0 THEN WHILE lock%<>0 ~Examine(lock%,fileinfo%) level$(currlev%)=CHAR{fileinfo%+8} IF level$(currlev%)="" THEN level$(currlev%)="RAM" ENDIF currlev%=currlev%+1 templock%=ParentDir(lock%) ~UnLock(lock%) lock%=templock% WEND ' IF UPPER$(level$(currlev%-1))="RAM DISK" THEN level$(currlev%-1)="RAM" ENDIF ' directory$=level$(currlev%-1)+":" FOR l%=currlev%-2 DOWNTO 0 directory$=directory$+level$(l%)+"/" NEXT l% ~FreeMem(fileinfo%,260) ELSE diskerror!=TRUE ~UnLock(lock%) ENDIF ENDIF RETURN > PROCEDURE get_path_string(VAR directory$) ' ' Works out the entire path name for the current directory and returns ' it in the string DIRECTORY$. i.e. DIRECTORY$ already has the path name, ' but this function changes it to the full path name (if necessary)." ' A flag, DISKERROR!, will be set to true if unable to lock the path. ' i.e. does the same as the GFA-Basic command DIR$(0) but it does ' not loose 40 bytes every time it is run! ' curdir$=directory$+CHR$(0) ! null-terminated for dos.library ' lock%=Lock(V:curdir$,-2) fexpandlock(lock%,directory$) ' RETURN > PROCEDURE set_current_dir(thedir$) ' ' Makes the specified directory the default one ' (same as CHDIR but doesn't crash if dir not exist) ' IF EXIST(thedir$) THEN CHDIR thedir$ ENDIF RETURN > PROCEDURE replace_requester(file$,VAR replace!) ' ' Checks to see if a file already exists - if so then the user is ' told of this and ask if he/she wants to continue ' replace!=TRUE IF file$<>"" THEN IF EXIST(file$) THEN request("ATTENTION : File Already Exists!|"+CHR$(34)+file$+CHR$(34),"OVERWRITE",cancel$,x%) IF x%=0 THEN replace!=FALSE ENDIF ELSE ENDIF ENDIF RETURN > PROCEDURE confirm_new_file(okay$) ' ' Displays a requester if the current document has been updated, and allows ' the user to save it if he/she wants to. This routine is called before ' Loading a new file. The parameter OKAY$ states the text to be used for ' the okay gadget in the requester. ' LOCAL tempfile$,curfile$ ' IF (docupdated! OR lineupdated!) THEN IF curfilename$<>"" THEN split_filename(curfilename$,dummy$,curfile$) curfile$=CHR$(34)+curfile$+CHR$(34) ELSE curfile$="Current File" ENDIF ' request(curfile$+" Has Been Updated.|Do You Wish To Save It First?",okay$,"SAVE IT",x%) IF x%=0 tempfile$=filename$ tempfile2$=thefile$ @save_as filename$=tempfile$ thefile$=tempfile2$ ENDIF ENDIF RETURN > PROCEDURE modify_protection(VAR bits%,flag%) LOCAL hit!,okay!,cancel! open_window(2,115,50,410,125,"Modify File Protection Bits") IF NOT unable_to_open_window! THEN draw_box(2,20,20,410-20,35) draw_box(2,20,37,410-20,90) colour2(2,pen1%,backcol%) text(2,43,30,"Filename :") text(2,53,50,"Deleteable :") text(2,53,61,"Executable :") text(2,69,72,"Writable :") text(2,69,83,"Readable :") text(2,244,50,"Archive :") text(2,266,61,"Pure :") text(2,252,72,"Script :") text(2,252,83,"Hidden :") colour2(2,pen2%,backcol%) text(2,132,30,thefile$) create_gadget(2,22,100,"MODIFY",gad1%()) create_gadget(2,324,100,cancel$,gad2%()) show_protection_bits(bits%) REPEAT test_for_sleep(2) test_gadget(2,h%(),hit!) ! bit 7 = hidden flag IF hit! THEN bits%=BCHG(bits%,7) show_protection_bits(bits%) ENDIF ' test_gadget(2,s%(),hit!) ! bit 6 = script flag IF hit! THEN bits%=BCHG(bits%,6) show_protection_bits(bits%) ENDIF ' test_gadget(2,p%(),hit!) ! bit 5 = pure flag IF hit! THEN bits%=BCHG(bits%,5) show_protection_bits(bits%) ENDIF ' test_gadget(2,a%(),hit!) ! bit 4 = archive flag IF hit! THEN bits%=BCHG(bits%,4) show_protection_bits(bits%) ENDIF ' test_gadget(2,r%(),hit!) ! bit 3 = read flag IF hit! THEN bits%=BCHG(bits%,3) show_protection_bits(bits%) ENDIF ' test_gadget(2,w%(),hit!) ! bit 2 = write flag IF hit! THEN bits%=BCHG(bits%,2) show_protection_bits(bits%) ENDIF ' test_gadget(2,e%(),hit!) ! bit 1 = e flag IF hit! THEN bits%=BCHG(bits%,1) show_protection_bits(bits%) ENDIF ' test_gadget(2,d%(),hit!) ! bit 0 = delete flag IF hit! THEN bits%=BCHG(bits%,0) show_protection_bits(bits%) ENDIF ' test_gadget(2,gad1%(),okay!) test_gadget(2,gad2%(),cancel!) IF event_key$=CHR$(13) THEN okay!=TRUE ELSE IF event_key$=CHR$(27) cancel!=TRUE ENDIF UNTIL okay! OR cancel! OR abortgadget! test_gadget_keypress(2,gad1%(),okay!) test_gadget_keypress(2,gad2%(),cancel!) ' IF okay! THEN flag%=1 ELSE flag%=0 ENDIF close_window(2) ENDIF RETURN > PROCEDURE show_protection_bits(bits%) ' ' displays the protection bits which have been selected for a file ' these are toggled on and off. there are eight flags : HSPARWED ' y%=41 show_switch(2,(bits% AND 1)=0,155,y%,d%()) show_switch(2,(bits% AND 2)=0,155,y%+11,e%()) show_switch(2,(bits% AND 4)=0,155,y%+22,w%()) show_switch(2,(bits% AND 8)=0,155,y%+33,r%()) show_switch(2,(bits% AND 16)<>0,322,y%,a%()) show_switch(2,(bits% AND 32)<>0,322,y%+11,p%()) show_switch(2,(bits% AND 64)<>0,322,y%+22,s%()) show_switch(2,(bits% AND 128)<>0,322,y%+33,h%()) ' RETURN > PROCEDURE chmod ' ' Procedure to modify the protection bits of a file (HSAPRWED) ' requires tow other procedures : ModifyProtection & ShowProtBits ' LOCAL status%,lock%,adr% oldpath$=path$ oldfile$=thefile$ get_file(2,"Modify Protection Bits","MODIFY",status%) IF status%<>0 THEN adr%=AllocMem(260,1) IF adr%<>0 dosname$=filename$+CHR$(0) lock%=Lock(V:dosname$,-2) IF lock%<>0 THEN ~Examine(lock%,adr%) ~UnLock(lock%) protbits%=LPEEK(adr%+116) modify_protection(protbits%,status%) IF status%<>0 THEN ~SetProtection(V:dosname$,protbits%) ENDIF ELSE file_not_found(filename$) ENDIF ~FreeMem(adr%,260) ENDIF ENDIF path$=oldpath$ thefile$=oldfile$ RETURN > PROCEDURE is_device_mounted(file$) ' ' Checks to see if the device that the file, FILE$, is on is actually ' mounted. This will stop system requesters like `Replace Volume xxxx'. ' If the device is there then DISKERROR! will be false, but if the device ' is not mounted then an error message is displayed and DISKERROR! will ' be set to true. ' LOCAL device$ file$=LEFT$(file$,INSTR(file$,":")) ' IF file$=":" OR file$="" THEN file$=LEFT$(defaultdir$,INSTR(defaultdir$,":")) ENDIF ' diskerror!=FALSE IF UPPER$(file$)<>"RAM:" THEN assign(device$) ! get the list of devices IF INSTR(UPPER$(device$),UPPER$(file$))=0 THEN diskerror!=TRUE ENDIF ENDIF RETURN > PROCEDURE file_not_found(filename$) ' ' Gives a standard "file not found" message ' inform("DISK ERROR : File Not Found !|"+CHR$(34)+filename$+CHR$(34)) RETURN > PROCEDURE split_filename(filename$,VAR path$,file$) ' ' takes a filename and splits it up into its path and file strings ' LOCAL exist%,a$,l% path$=filename$ file$="" file_type(filename$,exist%) IF exist%<=0 THEN FOR l%=LEN(filename$) DOWNTO 1 a$=MID$(filename$,l%,1) EXIT IF a$=":" OR a$="/" path$=LEFT$(path$,LEN(path$)-1) file$=a$+file$ NEXT l% ENDIF RETURN > PROCEDURE append_filename(dir$,file$,VAR filename$) ' ' Appends a filename onto a directory name ensuring that an exta ' backslash "/" character is inserted if necessary ' IF TRIM$(dir$)="" THEN LET dir$=defaultdir$ ENDIF ' IF RIGHT$(dir$,1)<>":" AND RIGHT$(dir$,1)<>"/" THEN filename$=dir$+"/"+file$ ELSE filename$=dir$+file$ ENDIF RETURN > PROCEDURE is_disk_in_drive(drive%,VAR indrive!) ' ' This procedure checks to see if there is a disk in drive number DRIVE. ' If there is, then INDRIVE! will return a true result, otherwise, a ' false result will be returned. This involves direct access to the ' trackdisk.device and sending a TD_CHANGESTATE command to check the ' status of a particular disk unit. If the parameter DRIVE is the value ' of a non-existent disk unit or invalid in any other way, then INDRIVE! ' will return true by default. ' LOCAL devname$,status%,diskport%,request% ' indrive!=TRUE ' ' Create a MessagePort which will be used for an message reports. ' This structure acts as an anchor point for device communication. ' diskport%=CreatePort(0,0) IF diskport%<>0 THEN ' ' Create a device request structure and initialise it. ' This is the structure which controlls the device. ' request%=CreateExtIO(diskport%,56) IF request%<>0 THEN ' ' Open the trackdisk.device using the device request structure ' which has been allocated and initialised. ' devname$="trackdisk.device"+CHR$(0) IF OpenDevice(V:devname$,drive%,request%,0)=0 THEN ' ' Set up the IOStdReq structure to send the TD_CHANGESTATE command ' DPOKE request%+28,14 ! io_Command = TD_CHANGESTATE POKE request%+30,1 ! io_Flags = IOF_QUICK ' ' Send the command to the trackdisk.device with the DoIo() call ' ~DoIO(request%) ' ' The result of the Hi There 4Ìvalue denoting no disk in the specified drive. ' value denoting no disk in the specified drive. ' IF LPEEK(request%+32)<>0 THEN indrive!=FALSE ENDIF ~CloseDevice(request%) ENDIF delete_ext_io(request%,56) ENDIF ~DeletePort(diskport%) ENDIF RETURN > PROCEDURE get_filename(filename$,VAR file$) ' ' Returns an uppercase only verison of the file part of a filename ' INLINE buff%,2 ' file$="" FOR l%=LEN(filename$) DOWNTO 1 POKE buff%,ASC(UPPER$(MID$(filename$,l%,1))) EXIT IF CHR$(PEEK(buff%))=":" OR CHR$(PEEK(buff%))="/" file$=CHR$(PEEK(buff%))+file$ NEXT l% RETURN ' ************************** PREFERENCES ROUTINES *************************** > PROCEDURE updatepencolours ' ' ' IF screencolours%<>2 THEN pen1%=pen1col% pen2%=pen2col% ELSE backcol%=0 pen1%=1 pen2%=1 ENDIF RETURN > PROCEDURE set_colours FOR l%=0 TO 3 ~SetRGB4(ViewPortAddress(winptr%(0)),l%,colour%(l%,0),colour%(l%,1),colour%(l%,2)) NEXT l% RETURN > PROCEDURE get_workbench_colours ' ' Gets the current default screen colours from the WorkBench. ' the data is copied into the 2-D array COLOUR() ' Preferences offset +110 for 3 words of 4 colors ' LOCAL prefstruct% ' DIM wbcolour$(3) ' prefstruct%=AllocMem(232,1) IF prefstruct%<>0 THEN ~GetDefPrefs(prefstruct%,232) wbcolour$(0)=HEX$(DPEEK(prefstruct%+110),3) wbcolour$(1)=HEX$(DPEEK(prefstruct%+112),3) wbcolour$(2)=HEX$(DPEEK(prefstruct%+114),3) wbcolour$(3)=HEX$(DPEEK(prefstruct%+116),3) FOR l%=0 TO 3 colour%(l%,0)=VAL("$"+MID$(wbcolour$(l%),1,1)) colour%(l%,1)=VAL("$"+MID$(wbcolour$(l%),2,1)) colour%(l%,2)=VAL("$"+MID$(wbcolour$(l%),3,1)) NEXT l% ~FreeMem(prefstruct%,232) ENDIF ' ERASE wbcolour$() RETURN > PROCEDURE get_default_screen_colours ' ' Gets the screen colours from the default screen. ' This will normally be the WorkBench, but if EdWord ' is run from a custom screen (e.g. from Sid V2.0) ' then the custom screen will be the default screen. ' To get the colours, I lock the Intuition Base to ' find the active screen and then grab the colour map. ' LOCAL colourmap%,loop%,colour% ' ilock%=LockIBase(0) activescreen%={_IntBase+56} ~UnlockIBase(ilock%) ' IF activescreen%<>0 THEN colourmap%=LPEEK(activescreen%+48) FOR loop%=0 TO 3 colour%=GetRGB4(colourmap%,loop%) ' colour%(loop%,0)=SHR(colour% AND &HF00,8) colour%(loop%,1)=SHR(colour% AND &HF0,4) colour%(loop%,2)=colour% AND &HF ' wbcolour%(loop%,0)=colour%(loop%,0) wbcolour%(loop%,1)=colour%(loop%,1) wbcolour%(loop%,2)=colour%(loop%,2) NEXT loop% only_screen!=FALSE ELSE RESTORE workbench2_0 FOR l1%=0 TO 3 FOR l2%=0 TO 2 READ colour%(l1%,l2%) NEXT l2% NEXT l1% only_screen!=TRUE ENDIF ' RETURN > PROCEDURE save_old_colours ' ' Saves the custom screen colours so that they can be restored when ' returning to the custom screen after opening a workbench window ' FOR col%=0 TO 3 FOR hue%=0 TO 2 oldcolour%(col%,hue%)=colour%(col%,hue%) NEXT hue% NEXT col% RETURN > PROCEDURE restore_old_colours ' ' Called when going from WBench screen --> Custom screen ' Restores default WBench colours and old custom screen colours ' restore_workbench_colours FOR col%=0 TO 3 FOR hue%=0 TO 2 colour%(col%,hue%)=oldcolour%(col%,hue%) NEXT hue% NEXT col% RETURN > PROCEDURE restore_workbench_colours ' ' Sets the workbench colours to those specified by the preference structure ' IF wbench_colours_changed! AND (NOT only_screen!) THEN IF NOT use_wbench! THEN OPENS 0 OPENW #3,0,11,640,100,0,&H11900 ENDIF ' FOR pfeiffer%=0 TO 3 colour%(pfeiffer%,0)=wbcolour%(pfeiffer%,0) colour%(pfeiffer%,1)=wbcolour%(pfeiffer%,1) colour%(pfeiffer%,2)=wbcolour%(pfeiffer%,2) NEXT pfeiffer% set_colours ' IF NOT use_wbench! THEN CLOSEW #3 ENDIF wbench_colours_changed!=FALSE ENDIF RETURN > PROCEDURE standard_colours(version%) ' ' Copies the standard workbench colours into the COLOUR() array and ' sets them as the defaults. This routine is called by the COLOURS ' procedure and the parameter VERSION refers to the version of WorkBench ' colours required e.g. 1.3 or 2.0. The Colour window is also refreshed ' to reflect the new colours. ' LOCAL l1%,l2% ' tempcol%=col3% temppen1%=col1% temppen2%=col2% tempshadow1%=col2% tempshadow2%=col1% ' IF version%<2 THEN RESTORE workbench1_3 ELSE RESTORE workbench2_0 ENDIF ' FOR l1%=0 TO 3 FOR l2%=0 TO 2 READ colour%(l1%,l2%) NEXT l2% NEXT l1% set_colours ensure_embossed(tempshadow1%,tempshadow2%) update_colours(curcol%) display_colour_gadgets(temppen1%,temppen2%,tempback%,tempshadow1%,tempshadow2%,wincols%()) ' workbench1_3: DATA 0,5,10,15,15,15,0,0,2,15,8,0 workbench2_0: DATA 10,10,10,0,0,0,15,15,15,6,8,11 ' RETURN > PROCEDURE ensure_embossed(VAR shadow1%,shadow2%) ' ' **** LOOK AT PALETTE AND MAKE SHADOWS ALWAYS LOOK EMBOSSED BY DEFAULT **** ' LOCAL shadcol1%,shadcol2% ' shadcol1%=colour%(shadow1%,0)+colour%(shadow1%,1)+colour%(shadow1%,2) shadcol2%=colour%(shadow2%,0)+colour%(shadow2%,1)+colour%(shadow2%,2) IF shadcol1%>=shadcol2% THEN SWAP shadow1%,shadow2% ENDIF RETURN > PROCEDURE readln(VAR x$,x%,x!) ' ' Reads a line from the open file (on channel #1). If we are at the ' end of the file, then a message is printed, otherwise the next line ' read and returned in its three possible formats - string,integer,boolean ' IF prefpos%>=prefend% THEN readerror%=1 ELSE IF readerror%<>1 ' x$="" WHILE PEEK(prefpos%)<>10 AND prefpos% PROCEDURE writeln(x$) ' x$=x$+CHR$(10) ~Write(preflock%,V:x$,LEN(x$)) ' RETURN > PROCEDURE intwrite(x%) writeln(STR$(x%)) RETURN > PROCEDURE boolwrite(x!) writeln(STR$(x!)) RETURN > PROCEDURE save_config_file(dir$) ' ' Saves the variables which are listed in the Preference_File_Structure ' into a configuration file which can be loaded in at a later date. ' LOCAL dosfile$,lock%,file$ ' append_filename(dir$,configfile$,file$) replace_requester(file$,replace!) IF replace! THEN dosfile$=file$+CHR$(0) preflock%=Open(V:dosfile$,mode_new%) IF preflock%<>0 THEN ' writeln(configheader$) intwrite(tabsize%) writeln(command$(0)) writeln(command$(1)) writeln(command$(2)) writeln(commenu$(0)) writeln(commenu$(1)) writeln(commenu$(2)) boolwrite(autosave!(0)) boolwrite(autosave!(1)) boolwrite(autosave!(2)) boolwrite(delay!(0)) boolwrite(delay!(1)) boolwrite(delay!(2)) boolwrite(customwin!(0)) writeln(clititle$) writeln(clix$) writeln(cliy$) writeln(cliw$) writeln(clih$) writeln(setup$) intwrite(pitch%) boolwrite(nlq!) FOR l%=0 TO 9 writeln(fkey$(l%)) NEXT l% FOR l1%=0 TO 3 FOR l2%=0 TO 2 intwrite(colour%(l1%,l2%)) NEXT l2% NEXT l1% boolwrite(autoindent!) boolwrite(searchzoom!) boolwrite(keypad!) boolwrite(backups!) boolwrite(hexascii!) intwrite(memorysize%-memlow%) intwrite(0) ! REMOVED intwrite(0) ! REMOVED intwrite(keywordcase%) intwrite(variablecase%) writeln(keyfile$) writeln(pattern$) intwrite(screenres%) intwrite(screencolours%) boolwrite(use_wbench!) boolwrite(0) ! REMOVED boolwrite(saveicon!) intwrite(pen1col%) intwrite(pen2col%) intwrite(backcol%) intwrite(shadow1%) intwrite(shadow2%) boolwrite(showlinefeeds!) writeln(prtdevice$) boolwrite(tab2space!) intwrite(left_margin%) intwrite(right_margin%) intwrite(page_length%) boolwrite(manual_feed!) boolwrite(page_nos!) intwrite(start_page%) writeln(pageno_style$) boolwrite(linewrap!) intwrite(tb_margin%) boolwrite(pp_detect!) boolwrite(flash_gordon!) writeln(symbol1$) writeln(symbol2$) boolwrite(symbol_indent!) boolwrite(strip_eol!) boolwrite(auto_casing!) boolwrite(customwin!(1)) boolwrite(customwin!(2)) writeln(command_path$) FOR l1%=1 TO 5 writeln(arexx_script$(l1%)) NEXT l1% FOR l1%=0 TO 4 writeln(drive$(l1%)) NEXT l1% intwrite(word_wrap_cutoff%) boolwrite(word_wrap!) boolwrite(timed_save!) boolwrite(timed_ext!) intwrite(timed_mins%) intwrite(bottomline%+24) IF use_wbench! THEN intwrite(DPEEK(winptr%(0)+6)) ELSE intwrite(DPEEK(scrptr%(1)+10)) ENDIF boolwrite(use_underline!) boolwrite(alternate_cursor!) IF aslrequester%<>0 THEN intwrite(DPEEK(aslrequester%+22)) intwrite(DPEEK(aslrequester%+24)) intwrite(DPEEK(aslrequester%+26)) intwrite(DPEEK(aslrequester%+28)) ELSE intwrite((640-303) DIV 2) intwrite((screenres%-173) DIV 2) intwrite(303) intwrite(173) ENDIF boolwrite(use_asl!) boolwrite(alt_gadgets!) intwrite(zoom_x%) intwrite(zoom_y%) IF use_wbench! THEN intwrite(DPEEK(winptr%(0)+4)) ELSE intwrite(DPEEK(scrptr%(1)+8)) ENDIF writeln(macro_path$) FOR l1%=6 TO 10 writeln(arexx_script$(l1%)) NEXT l1% boolwrite(shiftdel_word!) intwrite(screenwidth%) ' @save_macro ' ~Close(preflock%) inform("Configuration File Has Been Saved") ENDIF ENDIF RETURN > PROCEDURE load_config_file(dir$) ' ' Loads an EdWord configuration file which is located in the directory ' specified by the procedure parameter. (See Preference_File_Structure ' for a list of the currently supported configuration file format). ' LOCAL x$,x%,x!,file$ ' append_filename(dir$,configfile$,file$) ' OPEN "I",#1,file$ preflength%=LOF(#1) CLOSE #1 ' prefbuffer%=AllocMem(preflength%,1) IF prefbuffer%<>0 THEN ' file$=file$+CHR$(0) preflock%=Open(V:file$,mode_old%) IF Read(preflock%,prefbuffer%,preflength%)<>0 THEN prefpos%=prefbuffer% prefend%=prefbuffer%+preflength% readln(a$,x%,x!) ' jody!=TRUE cutejody!=FALSE IF a$=oldconfigheader$ THEN cutejody!=TRUE request("Configuration File Is From An Older Version|Of EdWord. Do You Still Wish To Use It?","YES, USE IT","NO, FORGET IT",x%) IF x%=0 THEN jody!=FALSE ENDIF inform("You Can Update The Configuration File|By Running The UpdateConfig Program|Supplied With This Program") ELSE IF a$<>configheader$ inform("Not an EdWord V"+version$+" Configuration File!|Resorting To Default Configuration") jody!=FALSE ENDIF ' IF NOT jody! THEN default_config ELSE readerror%=0 readln(x$,tabsize%,x!) readln(command1$,x%,x!) readln(command2$,x%,x!) readln(command3$,x%,x!) readln(menuent1$,x%,x!) readln(menuent2$,x%,x!) readln(menuent3$,x%,x!) readln(x$,x%,autosave1!) readln(x$,x%,autosave2!) readln(x$,x%,autosave3!) readln(x$,x%,delay1!) readln(x$,x%,delay2!) readln(x$,x%,delay3!) readln(x$,x%,customwin1!) readln(clititle$,x%,x!) readln(clix$,x%,x!) readln(cliy$,x%,x!) readln(cliw$,x%,x!) readln(clih$,x%,x!) readln(setup$,x%,x!) readln(x$,pitch%,x!) readln(x$,x%,nlq!) FOR l%=0 TO 9 readln(x$,x%,x!) fkey$(l%)=x$ NEXT l% FOR l1%=0 TO 3 FOR l2%=0 TO 2 readln(x$,x%,x!) IF x%<>colour%(l1%,l2%) THEN colours_changed!=TRUE colour%(l1%,l2%)=x% ENDIF NEXT l2% NEXT l1% readln(x$,x%,autoindent!) readln(x$,x%,searchzoom!) readln(x$,x%,keypad!) readln(x$,x%,backups!) readln(x$,x%,hexascii!) readln(x$,memorysize%,x!) readln(x$,x%,x!) ! REMOVED readln(x$,x%,x!) ! REMOVED readln(x$,keywordcase%,x!) readln(x$,variablecase%,x!) readln(keyfile$,x%,x!) readln(pattern$,x%,x!) readln(x$,screenres%,x!) readln(x$,screencolours%,x!) readln(x$,x%,use_wbench!) readln(x$,x%,x!) ! REMOVED readln(x$,x%,saveicon!) readln(x$,pen1col%,x!) readln(x$,pen2col%,x!) readln(x$,backcol%,x!) readln(x$,shadow1%,x!) readln(x$,shadow2%,x!) readln(x$,x%,showlinefeeds!) readln(prtdevice$,x%,x!) readln(x$,x%,tab2space!) readln(x$,left_margin%,x!) readln(x$,right_margin%,x!) readln(x$,page_length%,x!) readln(x$,x%,manual_feed!) readln(x$,x%,page_nos!) readln(x$,start_page%,x!) readln(pageno_style$,x%,x!) readln(x$,x%,linewrap!) readln(x$,tb_margin%,x!) readln(x$,x%,pp_detect!) readln(x$,x%,flash_gordon!) readln(symbol1$,x%,x!) readln(symbol2$,x%,x!) readln(x$,x%,symbol_indent!) readln(x$,x%,strip_eol!) readln(x$,x%,auto_casing!) readln(x$,x%,customwin2!) readln(x$,x%,customwin3!) readln(command_path$,x%,x!) FOR l1%=1 TO 5 readln(x$,x%,x!) arexx_script$(l1%)=x$ NEXT l1% FOR l1%=0 TO 4 readln(x$,x%,x!) drive$(l1%)=x$ NEXT l1% readln(x$,word_wrap_cutoff%,x!) readln(x$,x%,word_wrap!) readln(x$,x%,timed_save!) readln(x$,x%,timed_ext!) readln(x$,timed_mins%,x!) readln(x$,custom_size%,x!) readln(x$,window_ycoord%,x!) readln(x$,x%,use_underline!) readln(x$,x%,alternate_cursor!) readln(x$,aslx%,x!) readln(x$,asly%,x!) readln(x$,aslw%,x!) readln(x$,aslh%,x!) readln(x$,x%,use_asl!) readln(x$,x%,alt_gadgets!) readln(x$,zoom_x%,x!) readln(x$,zoom_y%,x!) readln(x$,window_xcoord%,x!) readln(macro_path$,x%,x!) FOR l1%=6 TO 10 readln(x$,x%,x!) arexx_script$(l1%)=x$ NEXT l1% readln(x$,x%,shiftdel_word!) readln(x$,screenwidth%,x!) ' @load_macro ' custom_size!=TRUE IF aslrequester%<>0 THEN DPOKE aslrequester%+22,aslx% DPOKE aslrequester%+24,asly% DPOKE aslrequester%+26,aslw% DPOKE aslrequester%+28,aslh% ENDIF custom_size%=MAX(custom_size%,100) IF screenwidth%<300 THEN screenwidth%=640 ENDIF commenu$(0)=menuent1$ commenu$(1)=menuent2$ commenu$(2)=menuent3$ command$(0)=command1$ command$(1)=command2$ command$(2)=command3$ autosave!(0)=autosave1! autosave!(1)=autosave2! autosave!(2)=autosave3! delay!(0)=delay1! delay!(1)=delay2! delay!(2)=delay3! customwin!(0)=customwin1! customwin!(1)=customwin2! customwin!(2)=customwin3! IF symbol_indent! THEN strip(symbol1$,symbolsize1%,indent_sy$()) strip(symbol2$,symbolsize2%,unindent_sy$()) ENDIF ENDIF ' IF preflock%<>0 THEN ~Close(preflock%) ENDIF ' ELSE readerror%=1 cutejody!=FALSE ENDIF ' IF readerror%>0 AND (NOT cutejody!) THEN request("Configuration File Is Corrupt!|Do You Still Want To Use It?","IGNORE IT","USE IT ANYWAY",x%) IF x%<>0 THEN default_config get_default_screen_colours ENDIF ELSE IF keywordcase%<>0 THEN @load_keywords(FALSE) ENDIF ENDIF ~FreeMem(prefbuffer%,preflength%) ELSE default_config inform("Not Enough Memory To|Load Config File!") ENDIF RETURN > PROCEDURE default_config ' ' This procedure sets up some envirnoment variable defaults which ' are used if no ".config" file is specified. (Or when the one which ' was specified was corrupt) ' tabsize%=8 ! default tab size setting command$(0)="" ! no initial command 1 set up command$(1)="" ! no initial command 2 set up command$(2)="" ! no initial command 3 set up customwin!(0)=FALSE ! Use CLI window for command 1 customwin!(1)=FALSE ! Use CLI window for command 2 customwin!(2)=FALSE ! Use CLI window for command 3 clititle$="EdWord CLI" ! NewCLI name clix$="0" ! NewCLI x coord cliy$="11" ! NewCLI y coord cliw$="640" ! NewCLI width clih$=STR$(wbench_size%-11) ! NewCLI Height searchzoom!=FALSE ! Do my fancy zoom when searching keypad!=FALSE ! keypad = second cursor pad backups!=FALSE ! No backups by default hexascii!=FALSE ! ASCII displayed in decimal autoindent!=FALSE ! no autoindent auto_casing!=TRUE ! automatic global text casing shiftdel_word!=TRUE ! SHIFT+DEL = delete current word word_wrap!=FALSE ! no word wrap keywordcase%=0 ! Keyword casing is off variablecase%=0 ! Variable casing is off autosave!(0)=FALSE ! Save file before executing command autosave!(1)=FALSE ! Save file before executing command autosave!(2)=FALSE ! Save file before executing command delay!(0)=TRUE ! Prompt after command delay!(1)=TRUE ! Prompt after command delay!(2)=TRUE ! Prompt after command keyfile$="" ! no specified keyword file memorysize%=60000 ! default buffer size pattern$="#?" ! print all files in requester (*.*) custom_size!=FALSE ! Use full screen resolution screenres%=256 ! Default Resolution = PAL Hi-res screenwidth%=640 ! Default screen width = 640 pixels screencolours%=4 ! Number of colours (depth*2) use_wbench!=FALSE ! Use custom screen by default LET saveicon!=FALSE ! do not save icons by default" showlinefeeds!=FALSE ! do not show line feed characters linewrap!=TRUE ! Wrap large lines when printing prtdevice$="PRT:" ! Name of printer for output tab2space!=FALSE ! Do not convert tabs into spaces pp_detect!=TRUE ! Decrunch powerpacker files flash_gordon!=FALSE ! Will cursor flash ? symbol_indent!=FALSE ! No symbolic indenting strip_eol!=FALSE ! No stripping of EOLN blanks alt_gadgets!=FALSE ! Invert gadgets by default word_wrap_cutoff%=76 ! cut off point for word wrap facility drive$(0)="DF0:" ! drive$(1)="DF1:" ! The file requester default drive$(2)="DF2:" ! drive gadgets drive$(3)="DH0:" ! drive$(4)="RAM:" ! timed_save!=FALSE timed_ext!=TRUE timed_mins%=10 custom_size%=0 window_ycoord%=0 IF aslrequester%<>0 THEN DPOKE aslrequester%+22,(640-303) DIV 2 DPOKE aslrequester%+24,(screenres%-173) DIV 2 DPOKE aslrequester%+26,303 DPOKE aslrequester%+28,173 ENDIF use_asl!=FALSE zoom_x%=0 zoom_y%=0 window_xcoord%=0 updatepencolours ' commenu$(0)="User Command 1" commenu$(1)="User Command 2" commenu$(2)="User Command 3" FOR l%=0 TO 9 fkey$(l%)="" ! Erase all FKey definitions NEXT l% RETURN > PROCEDURE update_colours(col%) colour1(2,col%) pbox(2,254,32,307,53) colour2(2,pen1%,backcol%) text(2,297,70,STR$(col%+1)+" of "+STR$(screencolours%)) FOR l%=0 TO 2 a$=STR$(colour%(col%,l%)) text(2,155,38+l%*15," ") text(2,163-(LEN(a$)-1)*4,38+l%*15,a$) NEXT l% RETURN > PROCEDURE test_plus_or_minus(col%,move%,VAR array%()) ' ' test for a click over one of the plus/minus gadgets ' in the Colours window and increments or decrements ' the approprate colour register is this happens. ' test_gadget(2,array%(),test!) IF test! THEN colour%(curcol%,col%)=MAX(MIN(colour%(curcol%,col%)+move%,15),0) update_colours(curcol%) set_colours ENDIF RETURN > PROCEDURE new_memory_size(oldsize%,prompt!) ' ' Allocates the buffer memory specified by the MEMORYSIZE variable. If ' this amount of memory cannot be allocated, then the previous value ' of OLDSIZE bytes is restored. N.B. AvailMem($20000)=Largest Contiguous Mem ' hide_cursor!=FALSE IF (memorysize%+memlow%*2-oldsize%)>AvailMem(&H20000) THEN inform("Cannot Allocate That Much Memory!") memorysize%=oldsize% ELSE ' IF prompt! THEN request("Setting A New Buffer Will Erase Current|Document - Do You Really Want To Do That?","YES, DO IT",cancel$,x%) ELSE x%=1 ENDIF ' IF x%<>0 THEN IF oldsize%<>0 THEN ~FreeMem(docstart%,oldsize%) ENDIF ' docstart%=AllocMem(memorysize%,1) IF docstart%=0 THEN inform("Cannot Allocate That Much Memory!") memorysize%=oldsize% docstart%=AllocMem(memorysize%,1) IF docstart%=0 THEN request("PANIC! : Cannot Re-allocate Old Memory Buffer !@?*!","QUIT EDWORD BLOODY FAST!","",x%) buggeroff!=TRUE ENDIF memoryerror!=TRUE ! for load operation ENDIF reset_position ELSE memorysize%=oldsize% ENDIF ENDIF hide_cursor!=TRUE RETURN > PROCEDURE display_colour_gadgets(thepen1%,thepen2%,back%,s1%,s2%,VAR array%()) LOCAL x%,y%,l1%,l2%,on! ' x%=198 y%=102 FOR l1%=0 TO 3 FOR l2%=0 TO 4 SELECT l2% CASE 0 on!=(thepen1%=l1%) CASE 1 on!=(thepen2%=l1%) CASE 2 on!=(back%=l1%) CASE 3 on!=(s1%=l1%) CASE 4 on!=(s2%=l1%) ENDSELECT ' show_switch(2,on!,x%+l1%*29,y%+l2%*11,temparray%()) ' IF screencolours%=2 THEN gadget_off(2,temparray%()) ENDIF ' array%(l1%,l2%,0)=temparray%(0) array%(l1%,l2%,1)=temparray%(1) array%(l1%,l2%,2)=temparray%(2) array%(l1%,l2%,3)=temparray%(3) ' NEXT l2% NEXT l1% ' RETURN > PROCEDURE test_colour_gadgets(VAR thepen1%,thepen2%,back%,s1%,s2%,array%()) LOCAL l1%,l2%,l3%,old_value%,hit! ' FOR l1%=0 TO 3 FOR l2%=0 TO 4 temparray%(0)=array%(l1%,l2%,0) temparray%(1)=array%(l1%,l2%,1) temparray%(2)=array%(l1%,l2%,2) temparray%(3)=array%(l1%,l2%,3) ' test_gadget(2,temparray%(),hit!) ' IF hit! THEN pen%(0)=thepen1% pen%(1)=thepen2% pen%(2)=back% pen%(3)=s1% pen%(4)=s2% old_value%=pen%(l2%) ' IF old_value%<>l1% THEN pen%(l2%)=l1% ' thepen1%=pen%(0) thepen2%=pen%(1) back%=pen%(2) s1%=pen%(3) s2%=pen%(4) display_colour_gadgets(thepen1%,thepen2%,back%,s1%,s2%,array%()) ENDIF ENDIF NEXT l2% NEXT l1% ' RETURN ' ************************ ROUTINES FOR CASING TEXT ************************* > PROCEDURE install_case_tables ' ' Instead of using the UPPER$() function to convert characters into uppercase ' and a function which checks for (>="A" AND <="Z") to convert characters ' into lowercase, I use two arrays of 256 elements which corresponding to ' a mapping of any character onto its uppercase or lowercase counterpart. ' This method can make quite sizable speed increases for only a small memory ' cost. ' DIM uppercase$(255),lowercase$(255) DIM uppercase%(255),lowercase%(255) DIM whitespace!(255) ' ' Build up the data for the four arrays :- ' ' uppercase$() = holds all the uppercase characters for ascii codes 0-255 ' lowercase$() = holds all the lowercase characters for ascii codes 0-255 ' uppercase() = holds all the uppercase ascii codes from 0-255 ' lowercase() = holds all the lowercase ascii codes from 0-255 ' FOR loop%=0 TO 255 a$=CHR$(loop%) uppercase$(loop%)=UPPER$(a$) ' IF a$>="A" AND a$<"[" THEN a$=CHR$(loop%+32) ENDIF lowercase$(loop%)=a$ ' uppercase%(loop%)=ASC(uppercase$(loop%)) lowercase%(loop%)=ASC(lowercase$(loop%)) ' a$=UPPER$(a$) whitespace!(loop%)=NOT ((a$>="A" AND a$<"[") OR (a$>="0" AND a$<":") OR (a$="'") OR (a$="_") OR (a$="$") OR (a$=CHR$(10))) NEXT loop% ' RETURN > PROCEDURE memory_to_uppercase(start%,end%) ' ' Converts an address range in memory into Uppercase (this will hopefully ' be part of our document unless something silly happens!) ' FOR memloop%=start% TO end% POKE memloop%,uppercase%(PEEK(memloop%)) NEXT memloop% RETURN > PROCEDURE memory_to_lowercase(start%,end%) ' ' Converts an address range in memory into Lowercase (this will hopefully ' be part of our document unless something silly happens!) ' FOR memloop%=start% TO end% POKE memloop%,lowercase%(PEEK(memloop%)) NEXT memloop% RETURN > PROCEDURE memory_to_capitalise(start%,end%) ' ' Converts an address range in memory into a capitalised format e.g. "Hiya" ' POKE start%,uppercase%(PEEK(start%)) FOR memloop%=start%+1 TO end% POKE memloop%,lowercase%(PEEK(memloop%)) NEXT memloop% RETURN > PROCEDURE memory_to_fileformat(start%,end%) ' ' Converts an address range in memory into a the same format ' as a KeyWord from a Keyword Definition File. ' FOR memloop%=start% TO end% POKE memloop%,PEEK(start_of_keyword%+memloop%-start%) NEXT memloop% RETURN > PROCEDURE lower(VAR text$) ' ' Converts a string into lowercase ' FOR loop%=1 TO LEN(text$) MID$(text$,loop%,1)=lowercase$(ASC(MID$(text$,loop%,1))) NEXT loop% RETURN > PROCEDURE upperword ' ' Function called from the Utilities menu to convert the current word ' under the cursor into uppercase characters. ' case_word(TRUE) RETURN > PROCEDURE lowerword ' ' Function called from the Utilities menu to convert the current word ' under the cursor into lowercase characters. ' case_word(FALSE) RETURN > PROCEDURE case_word(uppercase!) ' ' This function is used by UpperWord and LowerWord to set the case ' for the current word under the cursor. If the input parameter ' UPPERCASE! is true, then the current word will be put into uppercase ' otherwise lowercase will be used ' start%=curradd% WHILE PEEK(start%-1)>=48 AND PEEK(start%-1)<123 AND start%>lineadd% start%=start%-1 WEND ' IF PEEK(start%)<>lf% THEN cursor_off curradd%=start% REPEAT IF uppercase! THEN POKE curradd%,ASC(UPPER$(CHR$(PEEK(curradd%)))) ELSE POKE curradd%,ASC(lowercase$(PEEK(curradd%))) ENDIF curradd%=curradd%+1 UNTIL ((PEEK(curradd%-1)<48 OR PEEK(curradd%-1)>122) AND (PEEK(curradd%)>=48 AND PEEK(curradd%)<123)) OR PEEK(curradd%)=lf% get_cursorx IF refresh! THEN refresh_page ELSE refresh_curr_line ENDIF cursor_on update_column ENDIF RETURN > PROCEDURE update_case_prop ' ' Works out where the proportional gadget should be and refreshes it ' IF keywords%>5 THEN cproppos=keypos%/keywords% cpropsize=MIN(5/keywords%,1) ELSE cproppos=0 cpropsize=1 ENDIF cproppos=INT(cproppos*cmaxpot%) cpropsize=INT(cpropsize*cmaxpot%) display_case_prop(1) RETURN > PROCEDURE display_case_prop(col%) ' ' displays the proportional gadget in colour COL ' IF cproppos+cpropsize=cmaxpot%-1 THEN cproppos=cproppos+1 ENDIF IF cproppos+cpropsize>cmaxpot% THEN cpropsize=cmaxpot%-cproppos ENDIF ' colour1(1,backcol%) pbox(1,308,108,320,108+cproppos) pbox(1,308,110+cproppos+cpropsize,320,148) colour2(1,col%,col0%) pbox(1,308,109+cproppos,320,109+cproppos+cpropsize) ' ' pbox(1,308,103,320,103+cproppos#) ' pbox(1,308,105+cproppos#+cpropsize#,320,143) ' colour2(1,col,col0) ' pbox(1,308,104+cproppos#,320,104+cproppos#+cpropsize#) RETURN > PROCEDURE case_prop_hit IF mouse! THEN IF event_x%>304 AND event_x%<324 AND event_y%>106 AND event_y%<150 display_case_prop(2) check_mouse_click WHILE mouse! cproppos=MAX(INT(event_y%-108-(cpropsize/2)),0) IF cproppos+cpropsize>cmaxpot% THEN cproppos=cmaxpot%-cpropsize ENDIF ' display_case_prop(2) newkeypos%=INT((cproppos*keywords%)/cmaxpot%) keypos%=newkeypos% refresh_keyword_list(keypos%) ' test_events(1) WEND update_case_prop ENDIF ENDIF RETURN > PROCEDURE refresh_keyword_list(VAR pos%) colour2(1,pen1%,backcol%) IF pos%>(keywords%-5) THEN pos%=keywords%-5 ENDIF IF pos%<0 THEN pos%=0 ENDIF FOR l%=0 TO 4 IF l%+pos%>keywords% text(1,85,115+l%*8,SPACE$(25)) ELSE text(1,85,115+l%*8,LEFT$(LEFT$(keyword$(l%+pos%),24)+SPACE$(24),25)) ENDIF NEXT l% RETURN > PROCEDURE case_text ' ' Defines the setup for the text casing function, allowing the user ' to load in a keyword definition file and put text casing on/off. ' LOCAL okay!,oldcasing%,olddecase!,oldkeycap!,oldvarcap! open_window(1,115,25,410,189,"Language Keyword Casing") IF NOT unable_to_open_window! THEN draw_box(1,20,21,385,85) draw_box(1,42,97,360,155) draw_box(1,79,107,300,149) draw_box(1,304,107,324,149) colour2(1,pen1%,backcol%) IF keywords%=0 THEN text(1,176,51,"none") ELSE text(1,176,51,STR$(keywords%)) ENDIF heading(1,410,24,"Definitions") text(1,30,38," Keywords File :") text(1,30,51,"No. Of Keywords :") text(1,30,64," Keyword Casing :") text(1,30,78,"Variable Casing :") heading(1,410,100,"Keyword List") create_gadget(1,80,165,"SYMBOL INDENT",gad6%()) create_gadget(1,332,29,"@LOAD",gad1%()) create_gadget(1,212,165,"ADDITIONAL",gad5%()) create_gadget(1,319,165,cancel$,gad0%()) create_gadget(1,20,165,confirm$,gad2%()) show_case_switch(1,keywordcase%,gad3%()) show_case_switch(2,variablecase%,gad4%()) update_case_prop refresh_keyword_list(keypos%) oldkeycap%=keywordcase% oldvarcap%=variablecase% newkeyfile!=FALSE IF NOT keywordsloaded! THEN gadget_off(1,gad3%()) gadget_off(1,gad4%()) gadget_off(1,gad5%()) ENDIF REPEAT string_gadget(1,179,38,18,60,keyfile$,exit%) ' test_gadget(1,gad0%(),cancel!) ! *** CANCEL *** test_gadget(1,gad2%(),okay!) ! *** OKAY *** test_gadget(1,gad1%(),test!) ! *** LOAD KEYWORDS *** ' IF exit%=2 THEN ! *** RETURN PRESSED *** okay!=TRUE ! Exit ELSE IF exit%<>0 IF exit%=-1 THEN keypos%=MAX(0,keypos%-1) ELSE keypos%=MIN(keywords%,keypos%+1) ENDIF refresh_keyword_list(keypos%) update_case_prop ENDIF ' IF test! THEN @load_keywords(TRUE) newkeyfile!=TRUE ignore_messages ENDIF ' case_prop_hit ' test_gadget(1,gad3%(),test!) ! *** CASING ON/OFF *** IF test! AND (keywordsloaded!) THEN next_case_switch(1,keywordcase%) show_case_switch(1,keywordcase%,gad3%()) ENDIF ' test_gadget(1,gad4%(),test!) ! *** DECASE NON-KEYWORDS *** IF test! AND (keywordsloaded!) THEN next_case_switch(2,variablecase%) show_case_switch(2,variablecase%,gad4%()) ENDIF ' test_gadget(1,gad5%(),test!) ! *** DELIMITERS *** IF test! AND (keywordsloaded!) THEN modify_delimiters ENDIF ' test_gadget(1,gad6%(),test!) ! *** SYMBOLIC INDENTING *** IF test! THEN modify_symbolic_indenting ENDIF ' update_case_flag UNTIL okay! OR cancel! OR abortgadget! test_gadget_keypress(1,gad2%(),okay!) close_window(1) ' IF NOT okay! THEN keywordcase%=oldkeycap% variablecase%=oldvarcap% ELSE IF keywordcase%<>0 THEN IF (newkeyfile! OR (oldkeycap%=0) OR (NOT globalcase!) OR (oldkeycap%<>keywordcase%) OR (oldvarcap%<>variablecase%)) AND noofchars%>1 set_global_case ENDIF defaultkeycase%=keywordcase% ENDIF ENDIF update_case_flag ENDIF RETURN > PROCEDURE load_keywords(show!) ' ' Loads a keyword file into the array KEYWORD$() and returns the number ' of keywords in the integer KEYWORDS. If SHOW! is true then the data ' is displayed on the screen. ' ' KeyWord File Format : ' ~~~~~~~~~~~~~~~~~~~~~ ' 1) Each keyword is entered on a separate line (any case, any order) ' 2) comments can be entered by making the 1st character a ";" ' 3) delimiters can be set with the variables DELIM_OPEN= and DELIM_CLOSE= ' 4) symbol indentation defined by INDENT_SYMBOL= and UNINDENT_SYMBOL= ' LOCAL tempfile$ ' is_device_mounted(keyfile$) IF NOT diskerror! THEN ' ' Keyword Definition Filename must end with ".key" ' IF UPPER$(RIGHT$(keyfile$,4))<>".KEY" THEN keyfile$=keyfile$+".key" ENDIF ' ' Load the Keyword Definition File (if it exists) ' jody!=FALSE IF show! THEN file_type(keyfile$,exist%) IF exist%>=0 THEN split_filename(keyfile$,path$,thefile$) IF UPPER$(path$)<>UPPER$(path$(2)) THEN newdir!(2)=TRUE ENDIF path$(2)=path$ thefile$(2)=thefile$ IF pcoff! THEN pattern$(2)="#?.key" ELSE pattern$(2)="#?.KEY" ENDIF get_file(2,"Load A Keyword File","LOAD",status%) IF status%<>0 AND filename$<>"" THEN keyfile$=filename$ file_type(keyfile$,exist%) ELSE jody!=TRUE exist%=0 ENDIF ENDIF ELSE file_type(keyfile$,exist%) ENDIF ' IF exist%<0 THEN OPEN "I",#1,keyfile$ keywords%=0 IF (LOF(#1)+2000)*3-prev_keyword_size%>FRE(0) THEN CLOSE #1 request("Not Enough Internal Memory To Load File!","THAT SUCKS","",x%) ELSE prev_keyword_size%=LOF(#1) CLOSE #1 ' ' Display loading message ' keybuffer%=AllocMem(prev_keyword_size%,1) IF keybuffer%=0 THEN inform("Sorry Matey! Cannot Allocate Enough Memory|To Load The Keyword Definition File!") ELSE IF show! THEN colour2(1,pen1%,backcol%) text(1,176,51,"Loading ...") ENDIF ' ' Find out how many lines of text are in the file ' dosname$=keyfile$+CHR$(0) keylock%=Open(V:dosname$,1005) IF Read(keylock%,keybuffer%,prev_keyword_size%)<0 THEN ~Close(keylock%) inform("Oh Dear! It Would Seem That Your Keyword|Definition File Is Corrupt!!!") ELSE ~Close(keylock%) @decrunch_keywords(keybuffer%,prev_keyword_size%) count_lines(keybuffer%,prev_keyword_size%,keywords%) ' ' Load the Keyword Def. File into an Array ' ERASE keyword$() DIM keyword$(keywords%) ' tempadd%=keybuffer% FOR l%=0 TO keywords%-1 nextkey%=tempadd% next_line(nextkey%) keybytes%=nextkey%-tempadd%-1 IF keybytes%>0 THEN keyword$(l%)=SPACE$(keybytes%) BMOVE tempadd%,V:keyword$(l%),keybytes% ENDIF tempadd%=nextkey% ' LINE INPUT #1,keyword$(l) NEXT l% ' ' Parse the Keyword Def. File ... ' hz%=0 symbol_indent!=FALSE FOR hl%=0 TO keywords% keyword$(hz%)=TRIM$(keyword$(hl%)) IF LEFT$(keyword$(hz%),11)="DELIM_OPEN=" THEN delim1$=RIGHT$(keyword$(hz%),LEN(keyword$(hz%))-11) strip(delim1$,delimsize1%,delimopen$()) ELSE IF LEFT$(keyword$(hz%),12)="DELIM_CLOSE=" delim2$=RIGHT$(keyword$(hz%),LEN(keyword$(hz%))-12) strip(delim2$,delimsize2%,delimclose$()) ELSE IF LEFT$(keyword$(hz%),14)="INDENT_SYMBOL=" symbol1$=RIGHT$(keyword$(hz%),LEN(keyword$(hz%))-14) strip(symbol1$,symbolsize1%,indent_sy$()) symbol_indent!=TRUE autoindent!=TRUE ELSE IF LEFT$(keyword$(hz%),16)="UNINDENT_SYMBOL=" symbol2$=RIGHT$(keyword$(hz%),LEN(keyword$(hz%))-16) strip(symbol2$,symbolsize2%,unindent_sy$()) symbol_indent!=TRUE autoindent!=TRUE ELSE IF LEFT$(keyword$(hz%),1)<>";" AND keyword$(hz%)<>"" hz%=hz%+1 ENDIF NEXT hl% keywords%=hz% ' ' Sort the keyword list and display how many keywords loaded ' sort_array(keywords%,FALSE,keyword$()) IF show! THEN colour2(1,pen1%,backcol%) text(1,176,51,STR$(keywords%)+" ") ENDIF ' keypos%=0 keywordsloaded!=TRUE IF show! THEN show_case_switch(1,keywordcase%,gad3%()) show_case_switch(2,variablecase%,gad4%()) create_gadget(1,212,165,"ADDITIONAL",gad5%()) refresh_keyword_list(keypos%) ENDIF ENDIF ~FreeMem(keybuffer%,prev_keyword_size%) ENDIF ENDIF ELSE IF NOT jody! diskerror!=TRUE ENDIF ENDIF ' IF show! THEN IF diskerror! THEN file_not_found(keyfile$) ENDIF update_case_prop ENDIF RETURN > PROCEDURE is_word_keyword(address%,VAR key!,size%) ' ' Uses an machine code search routine to see if a word is a keyword ' The procedure returns a value of true in KEY! if the word beginning ' at location ADDRESS is a keyword. The keyword length is returned in SIZE ' clear_registers reg%(0)=keywords% ! D0=Keywords reg%(8)=address% ! A0=Address reg%(10)=ARRPTR(keyword$()) ! A2=Keyword Array Pointer reg%(11)=V:size% ! A3=Length of keyword reg%(12)=V:key! ! A4=IsKey! ' RCALL mc68000iskeyword%,reg%() ' start_of_keyword%=reg%(8) RETURN > PROCEDURE modify_delimiters ' ' Lets the user changes the symbols which will be used to "delimit" the ' text casing routines. These would include such symbols as comment ' symbols in a program language. e.g. In Pascal, we want to delimit the ' text enclosed within a {...} or (*...*) section so that the text within ' that range will not have its casing status modified by the text caser. ' open_window(3,200,100,350,143,"Additional Definitions") IF NOT unable_to_open_window! THEN colour2(3,pen1%,backcol%) draw_box(3,20,21,350-20,63) heading(3,350,24,"Delimiters") text(3,50,40," Open Delimiters :") text(3,50,54,"Close Delimiters :") draw_box(3,20,73,350-20,111) heading(3,350,76,"Auto Casing") text(3,58,91,"Automatic Global Casing :") text(3,54,104,"(CTRL+F = Manual Global Casing)") create_gadget(3,155,120,confirm$,okay2%()) show_switch(3,auto_casing!,263,82,cancel2%()) refresh_string(3,205,54,9,delim2$) casepos%=0 REPEAT string_group(3,205,40,9,20,0,casepos%,delim1$,exit%) string_group(3,205,54,9,20,1,casepos%,delim2$,exit%) SELECT casepos% CASE 0 strip(delim1$,delimsize1%,delimopen$()) refresh_string(3,205,40,9,delim1$) CASE 1 strip(delim2$,delimsize2%,delimclose$()) refresh_string(3,205,54,9,delim2$) ENDSELECT casepos%=(casepos%+exit%+2) MOD 2 ' test_gadget(3,cancel2%(),test!) IF test! THEN auto_casing!=NOT auto_casing! show_switch(3,auto_casing!,263,82,cancel2%()) ENDIF ' test_gadget(3,okay2%(),test!) IF exit%=2 THEN test!=TRUE ENDIF UNTIL test! OR abortgadget! test_gadget_keypress(3,okay2%(),test!) close_window(3) ENDIF RETURN > PROCEDURE modify_symbolic_indenting ' ' This bit lets the user change the symbols which will be used for "symbolic ' indenting". This is a technique which is useful in programming languages ' which makes the editor indent the next line upon a certain symbol (e.g. a ' BEGIN command in Pascal or a { bracket in C) or unindent upon another ' symbol (e.g. an END in Pascal or a } bracket in C). ' open_window(3,170,60,380,111,"Symbolic Indentation") IF NOT unable_to_open_window! THEN draw_box(3,20,21,380-20,79) heading(3,380,24,"Definitions") colour2(3,pen1%,backcol%) text(3,30,40," Indent Symbols :") text(3,30,54,"Unindent Symbols :") text(3,93,71,"Symbol Indent : ") create_gadget(3,170,88,confirm$,okay2%()) show_switch(3,symbol_indent!,220,62,cancel2%()) refresh_string(3,188,54,19,symbol2$) casepos%=0 REPEAT string_group(3,188,40,19,50,0,casepos%,symbol1$,exit%) string_group(3,188,54,19,50,1,casepos%,symbol2$,exit%) SELECT casepos% CASE 0 strip(symbol1$,symbolsize1%,indent_sy$()) refresh_string(3,188,40,19,symbol1$) CASE 1 strip(symbol2$,symbolsize2%,unindent_sy$()) refresh_string(3,188,54,19,symbol2$) ENDSELECT casepos%=(casepos%+exit%+2) MOD 2 ' test_gadget(3,cancel2%(),test!) IF test! THEN symbol_indent!=NOT symbol_indent! show_switch(3,symbol_indent!,220,62,cancel2%()) ENDIF ' test_gadget(3,okay2%(),test!) IF exit%=2 THEN test!=TRUE ENDIF UNTIL test! OR abortgadget! test_gadget_keypress(3,okay2%(),test!) close_window(3) ' ' If symbolic indenting is on, then auto-indenting must be on also ' IF symbol_indent! THEN autoindent!=TRUE ENDIF ENDIF RETURN > PROCEDURE indent_symbolically(VAR autoindent$) ' ' Allows the indenting of text upon certain symbols. e.g. in Pascal, we ' could symbolically indent upon "Begin" and "End"s so that whenever a ' Begin is entered, the editor indents the next line with an extra tab and ' when End is entered, the editor unindents that line (removes a tab) ' ' This procedure updates the AUTOINDENT$ string which will contain the ' amount of tabs and spaces to indent the next line with (as returned by ' the Get_AutoIndent_String() procedure). ' IF symbol_indent! THEN ' ' Get a string containing the current line of text ' convert_line(lineadd%,1,oldcurline$) strip_eol(oldcurline$) ' ' Account for the tab -> space option ' IF tab2space! THEN tab$=SPACE$(tabsize%-MOD(LEN(autoindent$),tabsize%)) ELSE tab$=CHR$(tab%) ENDIF ' ' Remove any delimiters from the string ' curline$=UPPER$(oldcurline$)+CHR$(lf%) create_range(V:curline$,delrange%(),noofcoms%) curline$=LEFT$(curline$,LEN(curline$)-1) ' hiya%=LEN(curline$) FOR currcom%=1 TO noofcoms% IF delrange%(currcom%-1,1)=LEN(curline$) THEN hiya%=MIN(hiya%,delrange%(currcom%-1,0)-1) ENDIF NEXT currcom% curline$=TRIM$(LEFT$(curline$,hiya%)) ' ' Check for symbolic indent ' FOR sexy%=0 TO symbolsize1%-1 symbol$=indent_sy$(sexy%) IF RIGHT$(curline$,LEN(symbol$))=symbol$ THEN autoindent$=autoindent$+tab$ ENDIF NEXT sexy% ' ' Check for symbolic unindent ' FOR sexy%=0 TO symbolsize2%-1 symbol$=CHR$(tab%)+unindent_sy$(sexy%) IF RIGHT$(curline$,LEN(symbol$))=symbol$ THEN hiya%=LEN(curline$)-LEN(symbol$)+1 newcurline$=LEFT$(oldcurline$,hiya%-1)+RIGHT$(oldcurline$,LEN(oldcurline$)-hiya%) replace(lineadd%,oldcurline$,newcurline$) curradd%=curradd%-1 IF LEN(autoindent$)>0 THEN autoindent$=LEFT$(autoindent$,LEN(autoindent$)-1) ENDIF ELSE symbol$=" "+unindent_sy$(sexy%) IF RIGHT$(curline$,LEN(symbol$))=symbol$ THEN hiya%=LEN(curline$)-LEN(symbol$) implode%=1 ' endsofie%=MAX(hiya%+(tabsize%-MOD(hiya%,tabsize%))-tabsize%,0) FOR sofie%=hiya% DOWNTO endsofie% EXIT IF hiya%=0 EXIT IF MID$(curline$,hiya%,1)<>" " IF hiya%>endsofie% THEN hiya%=hiya%-1 implode%=implode%+1 ENDIF NEXT sofie% ' newcurline$=LEFT$(oldcurline$,hiya%)+RIGHT$(oldcurline$,LEN(symbol$)-1) replace(lineadd%,oldcurline$,newcurline$) curradd%=curradd%-(LEN(oldcurline$)-LEN(newcurline$)) IF LEN(autoindent$)>implode% THEN autoindent$=LEFT$(autoindent$,LEN(autoindent$)-implode%) ELSE autoindent$="" ENDIF ENDIF ENDIF NEXT sexy% ENDIF RETURN > PROCEDURE create_range(address%,VAR array%(),size%) ' ' Creates a list of SIZE ranges in the 2D array ARRAY(). Each one specifies ' any area of text which should not be cased because it is within a ' delimiter range. ARRAY(x,0)=delim start, ARRAY(x,1)=delim end ' The line is taken to start from location ADDRESS until the line feed. ' LOCAL a$,b$,tempbuffer%,tempsize% ' size%=0 tempbuffer%=0 tempsize%=0 clear_registers reg%(10)=V:tempbuffer% reg%(11)=V:tempsize% reg%(12)=V:address% RCALL mc68000makestring%,reg%() ' IF tempbuffer%<>0 THEN word$=UPPER$(CHAR{tempbuffer%}) FOR l%=1 TO delimsize1% a$=delimopen$(l%-1) b$=delimclose$(l%-1) delopen%=1 delclose%=1 WHILE INSTR(word$,a$,delopen%)>0 AND size%<20 array%(size%,0)=INSTR(word$,a$,delopen%) array%(size%,1)=INSTR(word$,b$,delclose%)+LEN(b$)-1 IF a$=b$ THEN array%(size%,1)=INSTR(word$,b$,array%(size%,1)+1)+LEN(b$)-1 ' IF array%(size%,1)<=0 THEN array%(size%,1)=LEN(word$) ENDIF ' delclose%=array%(size%,1)+1 delopen%=delclose% ELSE IF array%(size%,1)<=0 THEN array%(size%,1)=LEN(word$) ENDIF ' delclose%=array%(size%,1)+1 delopen%=array%(size%,0)+LEN(a$) ENDIF ' size%=size%+1 WEND NEXT l% ~FreeMem(tempbuffer%,tempsize%) ENDIF RETURN > PROCEDURE strip(VAR word$,numb%,array$()) ' ' Reformats a `Delimiter' string, putting each delimiter in an array ' Used to optimise the delimiter definitions. ' ARRAY$() = an array of all possible delimiters ' NUMB = number of delimiters in WORD$ ' LOCAL l%,size%,a$ ' word$=TRIM$(word$)+"," size%=LEN(word$) l%=1 numb%=0 WHILE l%0 THEN a$=MID$(word$,l%,x%-l%) l%=x%+1 ELSE a$=RIGHT$(word$,size%-l%+1) l%=size%+1 ENDIF a$=TRIM$(a$) ' IF a$<>"" THEN array$(numb%)=UPPER$(a$) numb%=numb%+1 ENDIF WEND ' word$="" FOR l%=1 TO numb% word$=word$+array$(l%-1) IF l% PROCEDURE set_case(VAR addr%) ' ' The actual text caser which sets the case for one line. This is called by ' Set_Global_Case() and Set_Block_Case(). ' IF keywordcase%<>0 AND PEEK(addr%)<>lf% THEN startaddr%=addr% create_range(addr%,delrange%(),noofcoms%) ' WHILE PEEK(addr%)<>lf% ' ' >>>> SKIP ANY LEADING WHITE SPACE CHARACTERS <<<< ' WHILE whitespace!(PEEK(addr%)) addr%=addr%+1 WEND ' IF PEEK(addr%)<>lf% THEN ' ' >>> WORK OUT IF WE ARE INSIDE A DELIMITER RANGE <<< ' incomment!=FALSE x%=addr%-startaddr%+1 m%=0 WHILE m%=delrange%(m%,0)) AND (x%0 THEN IF keyword! THEN ' ' >>> PUT A KEYWORD INTO UPPER/LOWER/CAPITALISED/FILE <<< ' SELECT keywordcase% CASE 1 ! UpperCase word memory_to_uppercase(addr%,addr%+length%-1) CASE 2 ! LowerCase word memory_to_lowercase(addr%,addr%+length%-1) CASE 3 ! Capitalise word memory_to_capitalise(addr%,addr%+length%-1) CASE 4 ! From File memory_to_fileformat(addr%,addr%+length%-1) ENDSELECT ELSE IF variablecase%<>0 ' ' >>> PUT VARIABLE INTO LOWERCASE/CAPITALISED/UPPERCASE <<< ' SELECT variablecase% CASE 1 ! LowerCase word memory_to_lowercase(addr%,addr%+length%-1) CASE 2 ! Capitalise word memory_to_capitalise(addr%,addr%+length%-1) CASE 3 ! UpperCase word memory_to_uppercase(addr%,addr%+length%-1) ENDSELECT ENDIF addr%=addr%+length% ENDIF ENDIF ENDIF WEND ENDIF addr%=addr%+1 ! move address onto start of next line RETURN > PROCEDURE set_global_case ' ' This routine sets the Text Case for the entire document. ' IF keywordcase%<>0 AND auto_casing! THEN ' ' IF warnings! THEN request("Do You Wish To Set The|Text Case For Document?",accept$,cancel$,x%) ' ELSE ' x=1 ' ENDIF ' ' IF x<>0 THEN docupdated!=TRUE banner("Setting Case : ") gx%=(screenwidth% DIV 2)+10 gy%=bany%-6 draw_reverse_box(0,gx%-2,gy%-1,gx%+101,gy%+7) colour1(0,0) pbox(0,gx%,gy%,gx%+100,gy%+6) colour1(0,3) set_pointer(1) helen%=docstart% oldpercent%=0 WHILE helen%117 set_case(helen%) newpercent%=(helen%-docstart%)*100 DIV noofchars% IF oldpercent%<>newpercent% THEN pbox(0,gx%+oldpercent%,gy%,gx%+newpercent%,gy%+6) oldpercent%=newpercent% ENDIF WEND set_pointer(0) ignore_messages close_banner globalcase!=TRUE ENDIF ' ENDIF RETURN > PROCEDURE set_block_case(start%,size%) IF keywordcase%<>0 THEN docupdated!=TRUE banner("Setting Global Case For Block ... Please Wait") set_pointer(1) helen%=start% WHILE helen%117 set_case(helen%) WEND set_pointer(0) ignore_messages close_banner ENDIF RETURN > PROCEDURE set_case_if_changed free_abyss lineoverflow!=FALSE IF lineupdated! THEN strip_eol_blanks(strip_eol!) IF keywordcase%<>0 THEN joanne%=lineadd% set_case(joanne%) refresh_curr_line ENDIF lineupdated!=FALSE docupdated!=TRUE ENDIF RETURN > PROCEDURE manual_global_case ' ' Lets the user manually set the case for an entire document. This function ' is called when the user presses CTRL+F. ' LOCAL temp_auto_casing! ' IF keywordsloaded! THEN IF keywordcase%<>0 THEN temp_auto_casing!=auto_casing! auto_casing!=TRUE set_global_case auto_casing!=temp_auto_casing! ELSE inform("Keyword Casing is Off|Cannot Set Global Case") ENDIF ELSE inform("No Keyword Definition File|Has Been Loaded Yet!|Cannot Set Global Case.") ENDIF RETURN > PROCEDURE show_case_switch(switch%,flag%,VAR array%()) ' ' Displays either the Keyword Casing or the Variable Casing ' swirl gadget (when SWITCH = 1 or 2, repectively). The ' value FLAG represents KeywordCase or Variable Case and ' ARRAY holds the definition of the created gadget. ' clare%=55+(switch%-1)*14 ' IF flag%<>0 THEN IF flag%<4 THEN SELECT MOD(switch%+flag%-2,3) CASE 0 create_swirl_gadget(1,170,clare%,"@UPPERCASE ",array%()) CASE 1 create_swirl_gadget(1,170,clare%,"@LOWERCASE ",array%()) CASE 2 create_swirl_gadget(1,170,clare%,"@CAPITALISE ",array%()) ENDSELECT ELSE create_swirl_gadget(1,170,clare%,"@FROM FILE ",array%()) ENDIF ELSE create_swirl_gadget(1,170,clare%,"@OFF ",array%()) ENDIF RETURN > PROCEDURE next_case_switch(switch%,VAR flag%) flag%=(flag%+1) MOD (6-switch%) RETURN > PROCEDURE strip_eol(VAR text$) ' ' strips all spaces and tabs from the end of the input string, TEXT$ ' LOCAL a$ a$=RIGHT$(text$,1) WHILE a$=" " OR a$=CHR$(tab%) text$=LEFT$(text$,LEN(text$)-1) a$=RIGHT$(text$,1) WEND RETURN ' *************************** SEARCH ROUTINES ******************************* > PROCEDURE find_window(title$,showdirec!,VAR exit%) ' open_window(2,115,50,442,74,title$) IF NOT unable_to_open_window! THEN colour2(2,pen1%,backcol%) text(2,15,30," Find :") searchy%=46 create_gadget(2,20,searchy%,accept$,gad1%()) create_gadget(2,354,searchy%,cancel$,gad2%()) IF showdirec! THEN searchx%=104 ELSE searchx%=160 ENDIF ' IF showdirec! THEN update_search_gadgets(TRUE,TRUE) ELSE update_search_gadgets(TRUE,FALSE) ENDIF ' REPEAT string_gadget(2,101,30,37,80,find$,exit%) test_search_gadgets UNTIL okay! OR cancel! OR abortgadget! test_gadget_keypress(2,gad1%(),okay!) ' IF (NOT okay!) OR find$="" THEN exit%=0 ELSE exit%=1 ENDIF close_window(2) ELSE exit%=0 ENDIF RETURN > PROCEDURE find_replace_window(VAR exit%) ' open_window(2,115,50,442,94,"Find/Replace Text") IF NOT unable_to_open_window! THEN colour2(2,pen1%,backcol%) text(2,15,30," Find :") text(2,15,50," Replace :") searchx%=104 searchy%=67 showdirec!=TRUE create_gadget(2,20,searchy%,accept$,gad1%()) create_gadget(2,354,searchy%,cancel$,gad2%()) update_search_gadgets(TRUE,TRUE) casepos%=0 refresh_string(2,124,50,34,find_replace$) REPEAT string_group(2,124,30,34,80,0,casepos%,find$,exit%) string_group(2,124,50,34,80,1,casepos%,find_replace$,exit%) casepos%=(casepos%+exit%+2) MOD 2 test_search_gadgets UNTIL okay! OR cancel! OR abortgadget! test_gadget_keypress(2,gad1%(),okay!) ' IF (NOT okay!) OR find$="" THEN exit%=0 ELSE exit%=1 ENDIF close_window(2) ELSE exit%=0 ENDIF RETURN > PROCEDURE find_replace_options(VAR opt%) ' ' Prints 4 options for the Find/Replace facility and returns an integer ' value which describes the users selection, where :- ' 0 = Cancel ' 1 = Replace current word ' 2 = Replace all occurences ' 3 = Skip current word ' ' ' If called from an ARexx command, then Replace All by default ' IF arexx_command! THEN opt%=2 ELSE ypos%=50 IF cursory%>=4 AND cursory%<=10 THEN ypos%=110 ENDIF open_window(2,100,-ypos%,440,45,"Find/Replace Options") IF NOT unable_to_open_window! THEN create_gadget(2,20,20,"~REPLACE",gad1%()) create_gadget(2,126,20,"REPLACE ~ALL",gad2%()) create_gadget(2,268,20,"~SKIP",gad3%()) create_gadget(2,350,20,"~"+cancel$,gad4%()) cursor_on REPEAT test_for_sleep(2) test_gadget(2,gad1%(),gad1!) test_gadget(2,gad2%(),gad2!) test_gadget(2,gad3%(),gad3!) test_gadget(2,gad4%(),gad4!) ' event_key$=UPPER$(event_key$) IF event_key$=CHR$(13) OR event_key$="R" THEN gad1!=TRUE ELSE IF event_key$=CHR$(27) OR event_key$="C" gad4!=TRUE ELSE IF event_key$=" " OR event_key$="S" gad3!=TRUE ELSE IF event_key$="A" gad2!=TRUE ENDIF UNTIL gad1! OR gad2! OR gad3! OR gad4! OR abortgadget! test_gadget_keypress(2,gad1%(),gad1!) test_gadget_keypress(2,gad2%(),gad2!) test_gadget_keypress(2,gad3%(),gad3!) test_gadget_keypress(2,gad4%(),gad4!) opt%=0 IF gad1! THEN opt%=1 ENDIF IF gad2! THEN opt%=2 ENDIF IF gad3! THEN opt%=3 ENDIF close_window(2) ELSE opt%=3 ENDIF ENDIF RETURN > PROCEDURE find_hex_window(VAR exit%) ' open_window(2,115,50,410,94,"Find Hex String") colour2(2,pen1%,backcol%) IF NOT unable_to_open_window! THEN text(2,15,25," Hex String :") text(2,15,40," ASCII Text : `") text(2,17,57," eg. or will look for") colour1(2,pen2%) text(2,57,57,"40,41,31") text(2,153,57,"#64,"+CHR$(34)+"A"+CHR$(34)+",#49") text(2,361,57,"@A1") create_gadget(2,20,69,accept$,gad1%()) create_gadget(2,322,69,cancel$,gad2%()) IF forward! THEN create_swirl_gadget(2,150,69,"FORWARDS ",gad3%()) ELSE create_swirl_gadget(2,150,69,"BACKWARDS",gad3%()) ENDIF REPEAT create_hex_string(findhex$,a$) colour2(2,pen2%,backcol%) text(2,136,40,a$) colour2(2,pen1%,backcol%) text(2,137+LEN(a$)*8,40,"' ") ' string_gadget(2,135,25,31,80,findhex$,exit%) test_gadget(2,gad1%(),okay!) test_gadget(2,gad2%(),cancel!) test_gadget(2,gad3%(),temp!) IF temp! THEN forward!=NOT forward! IF forward! THEN create_swirl_gadget(2,150,69,"FORWARDS ",gad3%()) ELSE create_swirl_gadget(2,150,69,"BACKWARDS",gad3%()) ENDIF ENDIF IF exit%=2 THEN okay!=TRUE ENDIF UNTIL okay! OR cancel! OR abortgadget! test_gadget_keypress(2,gad1%(),okay!) ' IF cancel! OR findhex$="" OR abortgadget! THEN exit%=0 ELSE exit%=1 ENDIF close_window(2) ELSE exit%=0 ENDIF RETURN > PROCEDURE test_search_gadgets ' ' test gadgets for the search routines "Find" and "Find/Replace" ' tests OKAY,CANCEL,CASE DEPENDENCY,SEARCH DIRECTION ' this procedure is common to "FindWindow" & "FindReplaceWindow" procedures ' test_gadget(2,gad1%(),okay!) test_gadget(2,gad2%(),cancel!) test_gadget(2,gad3%(),dummy!) IF dummy!=TRUE THEN casedep!=NOT casedep! update_search_gadgets(TRUE,FALSE) ENDIF ' IF showdirec! THEN test_gadget(2,gad4%(),dummy!) IF dummy! THEN ' ' IF from_top! THEN ' from_top!=FALSE ' forward!=TRUE ' ELSE forward!=NOT forward! ' IF forward! THEN ' from_top!=TRUE ' ENDIF ' ENDIF ' update_search_gadgets(FALSE,TRUE) ENDIF ENDIF ' IF exit%=2 THEN okay!=TRUE ENDIF RETURN > PROCEDURE update_search_gadgets(a!,b!) ' IF a! THEN IF casedep! THEN create_swirl_gadget(2,searchx%,searchy%,"ABC != abc",gad3%()) ELSE create_swirl_gadget(2,searchx%,searchy%,"ABC == abc",gad3%()) ENDIF ENDIF ' IF b! THEN ' IF from_top! THEN ' create_swirl_gadget(2,233,searchy,"FROM TOP ",gad4()) ' ELSE IF forward! THEN create_swirl_gadget(2,233,searchy%,"FORWARDS ",gad4%()) ELSE create_swirl_gadget(2,233,searchy%,"BACKWARDS",gad4%()) ENDIF ' ENDIF ENDIF ' RETURN > PROCEDURE goto_line(line%,optimise!,display!) ' ' Sets the cursor over the first character on the line specified. ' If OPTIMISE! is not set, then the new line will be positioned ' at the top of the screen - otherwise, if the line is visible on ' screen then the cursor is moved and no screen refresh is made. ' This procedure is used by the search routines and for the prop gadget ' refresh!=FALSE newpage!=FALSE free_abyss IF display! THEN cursor_off ENDIF ' IF nooflines%<=maxrow% THEN optimise!=TRUE ENDIF ' IF line%>0 AND line%<=nooflines% THEN topline%=curline%-cursory% IF (line%>=topline% AND line%<=topline%+(maxrow%-1)) AND optimise! THEN WHILE curline%<>line% IF curline%>line% THEN curline%=curline%-1 prev_line(lineadd%) ELSE curline%=curline%+1 next_line(lineadd%) ENDIF WEND curradd%=lineadd% cursory%=curline%-topline% cursorx%=0 IF indent%>0 THEN indent%=0 IF display! THEN refresh_page ELSE refresh!=TRUE ENDIF ENDIF IF display! THEN cursor_on ENDIF ELSE newpage!=TRUE IF line%>nooflines%-(maxrow%-1) THEN lineadd%=docstart%+noofchars% prev_line(lineadd%) topadd%=lineadd% FOR l%=1 TO maxrow%-1 prev_line(topadd%) NEXT l% lineadd%=topadd% ' FOR l%=1 TO line%-nooflines%+maxrow%-1 next_line(lineadd%) NEXT l% curradd%=lineadd% curline%=line% cursory%=curline%-nooflines%+maxrow%-1 cursorx%=0 indent%=0 IF display! refresh_page ELSE refresh!=TRUE ENDIF ELSE WHILE topline%<>line% IF topline%>line% THEN topline%=topline%-1 prev_line(topadd%) ELSE topline%=topline%+1 next_line(topadd%) ENDIF WEND curline%=line% lineadd%=topadd% curradd%=topadd% cursory%=0 cursorx%=0 indent%=0 IF display! THEN refresh_page ELSE refresh!=TRUE ENDIF ENDIF ENDIF IF display! THEN update_prop ENDIF make_undo_string ENDIF RETURN > PROCEDURE find_occurence(VAR found!,tempadd%) ' ' Searches in the current direction for the next occurrence of ' FIND$. If it is found, then FOUND! is set to TRUE and the address ' of the first character is returned in TEMPADD. ' N.B. This procedure does not update the display in any way. ' LOCAL linefeeds%,lfoffset% ' lfoffset%=0 IF LEFT$(find$,1)<>CHR$(lf%) THEN IF PEEK(tempadd%)=lf% AND forward! THEN lfoffset%=1 ENDIF ELSE IF PEEK(tempadd%)<>lf% AND forward! THEN lfoffset%=-1 ENDIF ENDIF ' free_abyss findadd%=V:find$ clear_registers reg%(5)=LEN(find$) ! D5 = length of find string reg%(7)=casedep! ! D7 = case dependancy flag reg%(8)=V:tempadd% ! A0 = address to search from reg%(9)=V:found! ! A1 = text found flag reg%(10)=V:forward! ! A2 = direction of search reg%(11)=V:findadd% ! A3 = pointer to search text reg%(13)=V:docstart% ! A5 = start of document reg%(14)=V:noofchars% ! A6 = size of document ' RCALL mc68000findstring%,reg%() ' linefeeds%=reg%(10) ! get the no. of line feeds encountered IF NOT forward! THEN linefeeds%=-linefeeds% ENDIF ' search_line%=curline%+linefeeds%+lfoffset% ! return text line of occurence RETURN > PROCEDURE search_text(offset%,VAR found!,tempaddress%) ' ' Searches for the next occurence of FIND$ from the CURRADD. ' If found, then the cursor is repositioned at the occurrence ' and the flag FOUND! is updated as such. ' ' OFFSET = used to start the search so many characters after CURRADD ' TEMPADDRESS = address of occurence of text in memory ' found!=FALSE IF find$<>"" THEN cursor_off IF forward! THEN tempaddress%=curradd%+MAX(offset%,0) ELSE tempaddress%=curradd% ENDIF ' message("Searching ...") set_pointer(1) find_occurence(found!,tempaddress%) set_pointer(0) ' ' ******************* ZOOM INTO THE CURRENT POSITION ***************** IF found! THEN oldindent%=indent% goto_line(search_line%,TRUE,FALSE) curradd%=tempaddress% indent%=oldindent% get_cursorx IF refresh! OR newpage! THEN refresh_page ENDIF ' update_prop update_line update_column make_undo_string message("") zoom(FALSE) ENDIF cursor_on ELSE message("") ENDIF RETURN > PROCEDURE shift_fkey(code$) ' ' SHIFT + F1,F2,F3 = Set mark 1,2,3 ' SHIFT + F6,F7,F8 = Jump to mark 1,2,3 ' LOCAL fkey% fkey%=VAL(MID$(code$,3,1))+1 ' IF fkey%=5 THEN alert("Ooh Yes Baby! Press my SHIFT+F5 key! Don't Stop now !!") ELSE IF fkey%=4 alert("Nope, sorry, this key doesn't do anything at all!") ELSE IF fkey%=9 alert("Make mine a Pan-Galactic GargeBlaster, Zaphod.") ELSE IF fkey%=10 alert("You think you're tired now, but wait until 3.00") ELSE IF fkey%>0 AND fkey%<4 set_mark(fkey%) ELSE IF fkey%>5 AND fkey%<9 jump_to_mark(fkey%-5) ENDIF RETURN > PROCEDURE set_mark(numb%) ' ' Sets one of the three possible jump markers to the current line. ' This operation is used to jump directly to a predetermined line. ' SHIFT + F1,F2,F3 are used to access this function. ' NUMB must be in the range [1..3]. ' mark%(numb%-1,0)=curline% mark%(numb%-1,1)=curline%-cursory% mark%(numb%-1,2)=cursorx% IF NOT arexx_command! THEN alert("Bookmark "+STR$(numb%)+" Set At Line "+STR$(curline%)) ENDIF RETURN > PROCEDURE jump_to_mark(numb%) ' ' Jumps to the line number defined by one of the jump markers. ' This operation is used to jump directly to a predetermined line. ' SHIFT + F6,F7,F8 are used to access this function. ' NUMB must be in the range [1..3]. ' If the line number=0 then no operation is performed (Default) ' LOCAL lineno%,topno% ' lineno%=MIN(mark%(numb%-1,0),nooflines%) topno%=MAX(MIN(mark%(numb%-1,1),nooflines%-maxrow%+1),1) IF lineno%>0 THEN cursor_off ' goto_line(topno%,FALSE,FALSE) goto_line(lineno%,TRUE,FALSE) cursorx%=mark%(numb%-1,2) ' get_curpos update_column update_line refresh_page update_prop ' IF NOT arexx_command! THEN alert("Jumped To Bookmark "+STR$(numb%)+" (Line "+STR$(curline%)+")") ENDIF ENDIF RETURN > PROCEDURE move_marks(change%) ' ' Adds the value of CHANGE to all marks that are past the current line. ' This is done so that a mark always stays on the same line and does not ' change if lines are deleted or inserted. ' LOCAL currentline% ' IF SGN(change%)=1 THEN currentline%=curline%-1 ELSE currentline%=curline% ENDIF ' FOR loop%=0 TO 2 IF mark%(loop%,0)>currentline% THEN mark%(loop%,0)=mark%(loop%,0)+change% mark%(loop%,1)=mark%(loop%,1)+change% ENDIF NEXT loop% RETURN > PROCEDURE match_brackets LOCAL a$,b$,bracket$,increment%,endaddress%,templine%,tempadd%,depth% ' a$=CHR$(PEEK(curradd%)) ! The character under cursor IF INSTR("[]{}()",a$)>0 THEN ' ' Work out which character to look for (the opposite bracket) ' message("Searching ...") cursor_off bracket$="[][{}{()(" b$=MID$(bracket$,INSTR(bracket$,a$)+1,1) ' ' Do we search backwards or forwards for the matching bracket? ' IF INSTR("[({",a$)>0 THEN increment%=1 ELSE increment%=-1 ENDIF ' docsrt%=docstart%-1 docend%=docstart%+noofchars% templine%=curline% tempadd%=curradd% depth%=0 ' ' The main searching loop ... ' clear_registers reg%(0)=ASC(a$) ! D0 = a$ reg%(1)=ASC(b$) ! D1 = b$ reg%(2)=increment% ! D2 = increment reg%(8)=V:tempadd% ! A0 = tempadd reg%(9)=V:docsrt% ! A1 = DocStart reg%(10)=V:docend% ! A2 = DocEnd reg%(11)=V:depth% ! A3 = Depth reg%(12)=V:templine% ! A4 = TempLine RCALL mc68000matchbrackets%,reg%() ' ' Did we find a matching bracket ? ' IF depth%<0 THEN oldindent%=indent% goto_line(templine%,TRUE,FALSE) curradd%=tempadd% indent%=oldindent% get_cursorx IF refresh! OR newpage! THEN refresh_page ENDIF ' update_prop update_line update_column make_undo_string message("") zoom(FALSE) ELSE alert("Matching Bracket Not Found!") ENDIF cursor_on ELSE alert("Not over a [,],{,},( or ) character") ENDIF RETURN ' ****************** ROUTINES USED BY UTILITY SUBROUTINES ******************* > PROCEDURE display_drive_info(drv$) ' ' Access the dos.library to find out some information about the drive ' DRV$. Information displayed includes, TotalNoBlocks,UsedBlocks ' Disk Label and Disk Protection. This procedure also calls the virus ' check routine (in case the new disk has sumfink nasty on it). ' LOCAL fname$,temp%,total%,used%,fileinfo%,filelock%,nodiskerror! ' colour1(2,backcol%) pbox(2,157,94,317,146) colour2(2,pen2%,backcol%) text(2,160,101,drv$) ' diskindrive!=TRUE IF UPPER$(LEFT$(drv$,2))="DF" THEN is_disk_in_drive(VAL(MID$(drv$,3,1)),diskindrive!) ENDIF ' IF diskindrive! THEN drv$=drv$+CHR$(0) filelock%=Lock(V:drv$,-2) IF filelock%<>0 THEN fileinfo%=AllocMem(512,1) IF fileinfo%<>0 THEN ~Examine(filelock%,fileinfo%) fname$="" FOR l%=0 TO 18 a$=CHR$(PEEK(fileinfo%+l%+8)) EXIT IF a$=CHR$(0) fname$=fname$+a$ NEXT l% temp%=Info(filelock%,fileinfo%) total%=LPEEK(fileinfo%+12) used%=total%-LPEEK(fileinfo%+16) ' ' display the label name of the stated device ' text(2,160,111,fname$) ' ' show the amount of blocks available/used ' int2string(total%) text(2,160,121,aimee$+" ("+STR$(ROUND(total%/2))+"K)") int2string(used%) text(2,160,131,aimee$+" ("+STR$((used%*100) DIV total%)+"%)") ' ' Find out if the disk is protected or not ' IF PEEK(fileinfo%+11)=80 THEN text(2,160,141,"ON ") ELSE text(2,160,141,"OFF") ENDIF ~UnLock(filelock%) ENDIF ~FreeMem(fileinfo%,512) ELSE diskindrive!=FALSE ENDIF ENDIF ' IF NOT diskindrive! THEN text(2,160,111,"No Disk In Drive!") text(2,160,121,"n/a") text(2,160,131,"n/a") text(2,160,141,"n/a") ENDIF RETURN > PROCEDURE wireframe(col%) ' ' Draws the fireframe crosshair which is used for the SearchZoom facility. ' colour1(0,col%) graphmode(0,2) line(0,x1%,text_offset%,x1%,maxrow%*8+text_offset%) line(0,x2%,text_offset%,x2%,maxrow%*8+text_offset%) line(0,0,y1%-1+text_offset%,616,y1%-1+text_offset%) line(0,0,y2%-1+text_offset%,616,y2%-1+text_offset%) graphmode(0,1) RETURN > PROCEDURE zoom(forceit!) ' ' Performs a zoom in on any particular text co-ordinate. ' Used by search routines to show position of found text ' User has option to switch this ON/OFF on preferences window ' LOCAL x%,y%,step%,x1%,x2%,y1%,y2%,fin! ' IF searchzoom! OR forceit! THEN cursor_on x%=cursorx%*8 y%=cursory%*8 step%=8 x1%=0 x2%=624 y1%=0 y2%=maxrow%*8 ' wireframe(1) REPEAT wireframe(0) fin!=TRUE IF x1%(x%+8) THEN x2%=x2%-step% fin!=FALSE ENDIF IF y1%(y%+9) THEN y2%=y2%-step%/2 fin!=FALSE ENDIF wireframe(1) ' ' Wait for a vertical blank before updating screen. ' ~WaitTOF() UNTIL fin!=TRUE ' PAUSE 10 wireframe(0) ENDIF RETURN > PROCEDURE sort_array(size%,file_requester!,VAR array$()) ' ' This routine performs a case independant quick sort of an ' array of strings. The GFA-Basic commands QSORT and SSORT ' are both case sensitive in their operation which means ' that two words like "Clare" and "clare" are treated as ' different strings. The following code is a patch on the ' QSORT routine to make it sort in a case indenpedant manner. ' This involves substantial memory overheads and can take ' upto twice as long as the standard QSORT (but it is still ' faster than an optimised Selection Sort which I wrote in ' pure machine code !!!). ' DIM copy$(size%),upper$(size%),index%(size%) ' IF size%>1 THEN ' IF file_requester! THEN DIM sizes%(size%) ' FOR clare%=0 TO size% copy$(clare%)=array$(clare%) upper$(clare%)=UPPER$(array$(clare%)) index%(clare%)=clare% sizes%(clare%)=entrysize%(clare%) NEXT clare% ELSE FOR clare%=0 TO size% copy$(clare%)=array$(clare%) upper$(clare%)=UPPER$(array$(clare%)) index%(clare%)=clare% NEXT clare% ENDIF ' ' QSORT upper$(),size%,index%() ' ' IF file_requester! THEN FOR clare%=0 TO size% array$(clare%)=copy$(index%(clare%)) entrysize%(clare%)=sizes%(index%(clare%)) NEXT clare% ' ERASE sizes%() ELSE FOR clare%=0 TO size% array$(clare%)=copy$(index%(clare%)) NEXT clare% ENDIF ENDIF ' ERASE copy$(),upper$(),index%() RETURN > PROCEDURE get_line_number(title$,wlen%,message$,VAR numb%) ' ' Gets a line number from the user (that's probably why the procedure is ' called get_line_number eh!). This is routine is used by the Jump To Line ' and the Goto Byte Offset procedures. ' LOCAL cancel!,okay! ' open_window(2,160,50,wlen%,75,title$) IF NOT unable_to_open_window! THEN colour2(2,pen1%,backcol%) centre_text(2,message$,wlen%,25) create_gadget(2,20,50,accept$,gad1%()) create_gadget(2,wlen%-90,50,cancel$,gad2%()) ' okay!=FALSE cancel!=FALSE REPEAT number_gadget(2,(wlen%-7*8) DIV 2,40,7,6,numb%,exit%) test_gadget(2,gad1%(),okay!) test_gadget(2,gad2%(),cancel!) IF exit%=2 THEN IF numb%<>0 THEN okay!=TRUE ELSE cancel!=TRUE ENDIF ENDIF UNTIL okay! OR cancel! OR abortgadget! test_gadget_keypress(2,gad1%(),okay!) test_gadget_keypress(2,gad2%(),cancel!) ' IF NOT okay! THEN numb%=-1 ENDIF close_window(2) ELSE numb%=-1 ENDIF RETURN > PROCEDURE heading(window%,width%,y%,text$) ' ' This procedure will display the header text and complete a 3D-Box ' above it - This gives the effect which is used in the windows for ' such procedures like System Status, Word Count, Define Commands etc. ' to put an embossed heading to a raised 3D box ' LOCAL farx% x%=(width%-(LEN(text$)+2)*8) DIV 2 x%=x%-8 farx%=x%+(LEN(text$)+4)*8+1 colour2(window%,pen1%,backcol%) text(window%,x%+1,y%," "+text$+" ") line(window%,x%+17,y%+2,x%+17+LEN(text$)*8,y%+2) ' IF screencolours%>2 THEN colour1(window%,shadow2%) ELSE colour1(window%,shadow1%) ENDIF line(window%,x%,y%-3,x%,y%-9) line(window%,x%+1,y%-3,x%+1,y%-9) line(window%,x%+1,y%-9,farx%,y%-9) colour1(window%,shadow1%) line(window%,farx%,y%-3,farx%,y%-8) line(window%,farx%+1,y%-4,farx%+1,y%-9) colour2(window%,pen1%,backcol%) RETURN > PROCEDURE banner(text$) ' ' This procedure displays a message in the middle of the screen. It is ' used by the Text Casing routines and the Eexcute command routine to ' tell the user what's happening. There is no procedure to restore the ' screen to its initial display - you do this by performing a page ' refresh when you want to get rid of the message - i.e. write over it. ' LOCAL l% ' cursor_off bany%=(bottomline% DIV 2)-6 RASTPORT {winptr%(0)+50} GET 4,bany%-5+wboffset_y%,screenwidth%-4,bany%+15+wboffset_y%,banner_save$ colour1(0,backcol%) text$=" "+text$+" " l%=LEN(text$)*8 banx%=(screenwidth%-l%) DIV 2 pbox(0,banx%-10,bany%-5,banx%+l%+10,bany%+15) draw_box(0,banx%-11,bany%-5,banx%+l%+11,bany%+15) draw_box(0,banx%-2,bany%-1,banx%+l%+2,bany%+11) bany%=bany%+8 colour2(0,pen1%,backcol%) text(0,banx%,bany%,text$) RETURN > PROCEDURE close_banner ' ' Closes a banner window opened with the BANNER() procedure call ' IF bany%<>0 AND banner_save$<>"" RASTPORT {winptr%(0)+50} PUT 4,bany%-13+wboffset_y%,banner_save$ banner_save$="" ENDIF refresh_page RETURN > PROCEDURE create_hex_string(VAR temphex$,hex$) ' ' takes a string of numbers i.e. "$23,$23,$00,$10" and produces a string ' which is made up of charaters with those ASCII values. So given the above ' string, a four-byte string would be returned composing of CHR$($23)+ ' CHR$($23)+chr$($00)+chr$($10). It will also reformat the input string ' of characters, TEMPHEX$. ' hex$="" temp$="" IF RIGHT$(temphex$,1)<>"," THEN temphex$=temphex$+"," ENDIF xpos%=INSTR(temphex$,",") WHILE xpos%>0 byte$=TRIM$(LEFT$(temphex$,xpos%-1)) temphex$=RIGHT$(temphex$,LEN(temphex$)-xpos%) IF byte$<>"" SELECT ASC(LEFT$(byte$,1)) CASE 35 ! ASC("#") numb=MIN(ABS(VAL(RIGHT$(byte$,LEN(byte$)-1))),255) temp$=temp$+"#"+STR$(numb) CASE 36 ! ASC("$") numb=MIN(ABS(VAL(byte$)),255) temp$=temp$+"$"+HEX$(numb) CASE 34 ! ASC(""") numb=ASC(MID$(byte$,2)) REPEAT byte$=RIGHT$(byte$,LEN(byte$)-1) UNTIL LEFT$(byte$,1)="," OR byte$="" IF byte$<>"" THEN byte$=RIGHT$(byte$,LEN(byte$)-1) ENDIF temp$=temp$+CHR$(34)+CHR$(numb)+CHR$(34) DEFAULT ! No Prefix numb=MIN(ABS(VAL("&H"+byte$)),255) temp$=temp$+"$"+HEX$(numb) ENDSELECT hex$=hex$+CHR$(numb) temp$=temp$+"," ENDIF xpos%=INSTR(temphex$,",") WEND ' IF temp$<>"" THEN temphex$=LEFT$(temp$,LEN(temp$)-1) ELSE temphex$="" hex$="" ENDIF RETURN > PROCEDURE count_linefeeds(string$,VAR lfs%) ' ' Counts the number of line feeds in a string ' LOCAL loop% ' lfs%=0 FOR loop%=1 TO LEN(string$) IF MID$(string$,loop%,1)=CHR$(lf%) THEN lfs%=lfs%+1 ENDIF NEXT loop% RETURN > PROCEDURE replace(address%,VAR old$,new$) ' ' Will replace the text OLD$ at memory address, ADDRESS, with the new ' text NEW$. If an error occured (no memory) then a boolean, ERROR! will ' be set appropriately. Used for search/replace options as well as the ' vertical block routines. ' ' N.B. Make sure you `FreeAbyss' first Martin - remember what happened ' the last time you forget !!! ' LOCAL oldsize%,newsize%,linefeeds1%,linefeeds2% ' error!=FALSE oldsize%=LEN(old$) newsize%=LEN(new$) ' count_linefeeds(old$,linefeeds1%) count_linefeeds(new$,linefeeds2%) linefeed_diff%=linefeeds2%-linefeeds1% ' IF address%=memorysize% THEN memory_alert error!=TRUE ELSE ' IF oldsize%<>newsize% THEN IF newsize%>oldsize% THEN diff%=newsize%-oldsize% BMOVE address%,address%+diff%,docstart%+noofchars%-address%+1 noofchars%=noofchars%+diff% update_block_insert(linefeed_diff%,diff%) ELSE diff%=oldsize%-newsize% BMOVE address%+diff%,address%,docstart%+noofchars%-address%+1 noofchars%=noofchars%-diff% update_block_delete_char(linefeed_diff%,diff%) ENDIF ENDIF ' FOR l%=0 TO newsize%-1 POKE address%+l%,ASC(MID$(new$,l%+1,1)) NEXT l% docupdated!=TRUE ENDIF ENDIF ' nooflines%=nooflines%+linefeed_diff% ' IF linefeed_diff%<>0 THEN fullrefresh!=TRUE ELSE fullrefresh!=FALSE ENDIF RETURN > PROCEDURE replace_all cursor_off found!=TRUE error!=FALSE message("Replacing ...") set_pointer(1) replace_count%=0 WHILE found! AND (NOT error!) oldfile_size%=noofchars% replace_count%=replace_count%+1 replace(pos%,find$,find_replace$) IF NOT error! THEN IF forward! THEN pos%=pos%+LEN(find_replace$)-1 ELSE IF pos% PROCEDURE wordcount(address%,maxbytes%,VAR count%) ' ' Well, duuhhh!, wot could this procedure do I wonder ?!*? ' IF maxbytes%>0 THEN userquit!=FALSE clear_registers reg%(8)=V:address% ! A0 = Address reg%(9)=V:maxbytes% ! A1 = MaxBytes reg%(5)=tabsize% ! D5 = Tabsize RCALL mc68000wordcount%,reg%() ! cal M/Code routine ' count%=reg%(0) ELSE count%=0 ENDIF RETURN > PROCEDURE quantize(limit%,VAR string$) ' ' Returns a string containing a positive number within an upper limit ' string$=STR$(MIN(ABS(VAL(string$)),limit%)) RETURN > PROCEDURE get_duplicate(file$,VAR newfile$) ' ' gets the new filename of the file that is about to be renamed by ' the procedure Rename_File. If the user aborts the operation, ' then the output parameter NEWFILE$ will be a empty string. It will ' also be aborted if the user does not change the filename (as this ' would entail renaming the file as itself!) ' ' open_window(2,115,50,410,75,"Rename A File") IF NOT unable_to_open_window! THEN colour2(2,pen1%,backcol%) text(2,25,30,"Rename As :") create_gadget(2,28,47,accept$,gad1%()) create_gadget(2,315,47,cancel$,gad2%()) newfile$=file$ REPEAT string_gadget(2,127,30,30,80,newfile$,exit%) newfile$=TRIM$(newfile$) test_gadget(2,gad1%(),okay!) test_gadget(2,gad2%(),cancel!) IF exit%=2 THEN okay!=TRUE ENDIF IF okay! AND (newfile$="" OR UPPER$(newfile$)=UPPER$(file$)) THEN okay!=FALSE cancel!=TRUE ENDIF UNTIL okay! OR cancel! OR abortgadget! test_gadget_keypress(2,gad1%(),okay!) test_gadget_keypress(2,gad2%(),cancel!) close_window(2) ' IF NOT okay! THEN newfile$="" ENDIF ' ELSE newfile$="" ENDIF RETURN > PROCEDURE reset_position ' ' Resets all neccessary position variables to allow a complete restart ' IF NOT buggeroff! curradd%=docstart% lineadd%=docstart% topadd%=docstart% POKE docstart%,lf% curline%=1 nooflines%=1 indent%=0 cursorx%=0 cursory%=0 noofchars%=1 abyss%=0 globalcase!=FALSE false_eof!=FALSE docupdated!=FALSE linedated!=FALSE curfilename$="" undo$="" block_off window_title(0,"") update_prop update_column update_line ENDIF RETURN > PROCEDURE show_switch(window%,flag!,x%,y%,VAR array%()) create_gadget(window%,x%,y%,"@ ",array%()) IF flag! THEN tick_gadget(window%,x%+10,y%+3) ENDIF RETURN > PROCEDURE get_mem_offset(address%,screenoffset%,VAR memoffset%) ' ' given a cursor x coordinate, SCREENOFFSET, this function will ' return the equivalent memory address offset, MEMOFFSET, from ' the start of the line (at ADDRESS) from 0..BigNumber ' oldlineadd%=lineadd% oldcursorx%=cursorx% oldindent%=indent% ' lineadd%=address% cursorx%=screenoffset% indent%=0 get_curpos memoffset%=curradd%-lineadd% ' cursorx%=oldcursorx% lineadd%=oldlineadd% indent%=oldindent% RETURN > PROCEDURE convert_line(address%,mode%,VAR text$) ' ' Converts the line of text which is stored at memory location, ADDRESS ' into a text string. It will expand any tabs into the equivalent no. ' of spaces where necessary. ' ' MODE can take the following values :- ' 0 = Convert any tabs to spaces ' 1 = Leave tabs as a CHR$(9) character ' LOCAL memerr! ' startadd%=address% ! start address of text line endadd%=address% next_line(endadd%) endadd%=endadd%-1 ! address of CHR(10) at end of text line cursor%=0 ! size of line - LEN(text$) memerr!=FALSE ' IF mode%=0 ! Tab Convertion routine clear_registers reg%(8)=V:cursor% reg%(9)=V:startadd% reg%(10)=V:endadd% reg%(11)=V:tabsize% RCALL mc68000findcursor%,reg%() ! get the size of the text line in bytes ' IF FRE(0)>cursor%+30 THEN text$=SPACE$(cursor%+30) clear_registers reg%(8)=V:startadd% ! A0=text address (lineadd) reg%(9)=V:text$ ! A1=buffer address reg%(10)=V:cursor% ! A2=max buffer length reg%(11)=V:tabsize% ! A3=current tab size reg%(5)=0 ! D5=do not show line feeds RCALL mc68000convertstring%,reg%() ' text$=LEFT$(text$,cursor%) ELSE memerr!=TRUE ENDIF ELSE ! Direct Copy of memory into string space cursor%=endadd%-startadd% IF FRE(0)>cursor% THEN text$=SPACE$(cursor%) IF cursor%>0 THEN BMOVE address%,V:text$,cursor% ENDIF ELSE memerr!=TRUE ENDIF ENDIF ' IF memerr! THEN text$="" inform("Out Of Internal Memory!|Cannot Complete Operation") ENDIF RETURN > PROCEDURE decode(VAR text$) ' ' This procedure is used to decode a line of text which has been encoded ' with the above procedure `Encode' (strangely enuf!). The parameter passed ' in will be converted and returned out. ' FOR l%=1 TO LEN(text$) POKE V:text$+l%-1,ASC(MID$(text$,l%,1))-l%+4 NEXT l% RETURN > PROCEDURE change_resolution(force_change!) ' ' Changes the current screen resolution to a resolution ' appropriate to displaying NEWRES vertical lines and ' NEWCOL colours, with a flag NEW_WBENCH! specifying the ' use of a custom or workbench screen. ' curr_xcoord%=0 IF use_wbench! THEN curr_ycoord%=DPEEK(winptr%(0)+6) ELSE curr_ycoord%=DPEEK(scrptr%(1)+10) ENDIF ' ' Save custom screen colours if going from custom screen --> workbench ' IF screenres%<>newres% OR use_wbench!<>new_wbench! OR screencolours%<>newcol% OR (custom_size! AND custom_size%<>bottomline%+24) OR window_ycoord%<>curr_ycoord% OR force_change! THEN IF use_wbench! AND (NOT new_wbench!) THEN restore_old_colours ELSE IF (NOT use_wbench!) AND new_wbench! @save_old_colours ENDIF ' ' If changing from an NTSC hi-res screen to anything else, then set the ' flag which stores the ASCII table as a bitmap so that it refreshes ' the Table in the new screen mode. ' IF (screenres%<>newres%) AND (screenres%=200) OR (newres%=200) OR (newcol%<>screencolours%) THEN forget_ascii_screen ENDIF ' ' Deal with saving/restoring the allocating of colours when switching ' into and out of a 1-bitplane screen. ' IF newcol%=2 AND screencolours%=4 THEN backcol_old%=backcol% ENDIF IF newcol%=4 AND screencolours%=2 THEN backcol%=backcol_old% ENDIF ' screenres%=newres% ! Update resolution variable screencolours%=newcol% ! Update the depth of the screen use_wbench!=new_wbench! ! Update WBench screen flag updatepencolours ' close_screen open_screen ' IF winptr%(0)<>0 AND (NOT buggeroff!) THEN ' IF cursory%>maxrow%-1 THEN curradd%=docstart%+1 topadd%=docstart%+1 cursory%=0 cursor_bof ELSE refresh_page cursor_on ENDIF update_prop update_cur_char ' IF use_wbench! THEN wbench_colours_changed!=colours_changed! ENDIF ENDIF ENDIF RETURN > PROCEDURE display_integer(window%,x%,y%,number%) int2string(number%) text(window%,x%,y%,aimee$) RETURN > PROCEDURE int2string(number%) ' ' converts an integer variable into a string and puts commas after each ' 3rd digit. The result is stored in the global variable AIMEE$ ' LOCAL loop%,temp$,digit$ ' temp$=STR$(number%) aimee$="" ' FOR loop%=0 TO LEN(temp$)-1 digit$=MID$(temp$,LEN(temp$)-loop%,1) IF (loop%/3)=INT(loop%/3) AND loop%>0 THEN aimee$=digit$+","+aimee$ ELSE aimee$=digit$+aimee$ ENDIF NEXT loop% RETURN > PROCEDURE save_ascii_screen ' ' Saves the InsertASCII screen as a bitmap in memory so ' that it can redisplayed lightning fast later on. ' (This function only operates if there is enough memory) ' LOCAL asciiscreen$ ' forget_ascii_screen ' IF FRE(0)>(6500*screencolours%) THEN ' ' Saves window bitmap so that it can be displayed quickly next time ' GET 14,13,630,botline%,asciiscreen$ ascii_screen_size%=LEN(asciiscreen$) ' ' Allocate some memory to store the bitmap into ' ascii_screen%=AllocMem(ascii_screen_size%,1) IF ascii_screen%<>0 THEN BMOVE V:asciiscreen$,ascii_screen%,ascii_screen_size% ENDIF ENDIF RETURN > PROCEDURE restore_ascii_screen(VAR restored!) ' ' Restores the InsertASCII screen which was saved by the ' Save_Ascii_Screen procedure above. (ie. Displays it) ' LOCAL asciiscreen$ ' restored!=FALSE ' IF ascii_screen%<>0 THEN asciiscreen$="" old_add%=LPEEK(*asciiscreen$) old_len&=DPEEK(*asciiscreen$+4) LPOKE *asciiscreen$,ascii_screen% DPOKE *asciiscreen$+4,ascii_screen_size% PUT 14,13,asciiscreen$ LPOKE *asciiscreen$,old_add% DPOKE *asciiscreen$+4,old_len& restored!=TRUE ENDIF RETURN > PROCEDURE forget_ascii_screen ' ' This routine forgets about any bitmap which is currently ' being held in memory, saved by the Save_Ascii_Screen ' procedure. It will subsequently surrender all the memory ' which the bitmap was eating up. ' IF ascii_screen%<>0 THEN ~FreeMem(ascii_screen%,ascii_screen_size%) ascii_screen%=0 ENDIF RETURN ' ************************ CALCULATOR ROUTINES ***************************** > PROCEDURE calculate(operation$) LOCAL result,status%,number1,number2 ' number1=number(1) number2=number(2) status%=0 SELECT operation$ CASE "+" result=number1+number2 CASE "-" result=number1-number2 CASE "*" result=number1*number2 CASE "/" IF number2<>0 THEN result=number1/number2 ELSE status%=1 ENDIF CASE "^" IF ABS(number2)<=50 THEN result=number1^number2 ELSE status%=2 ENDIF DEFAULT result=number1 ENDSELECT ' number(1)=result number(2)=0 curr_number%=1 IF calc_mode%=0 AND INSTR(STR$(result),".")<>0 THEN floating_point!=TRUE floating_points%=LEN(STR$(result))-INSTR(STR$(result),".") ELSE floating_point!=FALSE ENDIF calculator_display(number(1),status%) floating_point!=FALSE RETURN > PROCEDURE calculator_gadgets ' ' Refreshes the number digits (0..F) on the calculator and then ghosts ' those which are not accessible in the current base mode (i.e. you cannot ' choose an A..F when working in decimal) ' create_gadget(2,20,56,"@ D ",g13%()) create_gadget(2,60,56,"@ E ",g14%()) create_gadget(2,100,56,"@ F ",g15%()) create_gadget(2,20,69,"@ A ",g10%()) create_gadget(2,60,69,"@ B ",g11%()) create_gadget(2,100,69,"@ C ",g12%()) create_gadget(2,20,82,"@ 7 ",g7%()) create_gadget(2,60,82,"@ 8 ",g8%()) create_gadget(2,100,82,"@ 9 ",g9%()) create_gadget(2,20,95,"@ 4 ",g4%()) create_gadget(2,60,95,"@ 5 ",g5%()) create_gadget(2,100,95,"@ 6 ",g6%()) create_gadget(2,20,108,"@ 1 ",g1%()) create_gadget(2,60,108,"@ 2 ",g2%()) create_gadget(2,100,108,"@ 3 ",g3%()) create_gadget(2,20,121,"@ 0 ",g0%()) create_gadget(2,60,121,"@ . ",o13%()) create_gadget(2,100,121,"@+/-",o14%()) ' IF calc_mode%<>1 THEN gadget_off(2,g15%()) gadget_off(2,g14%()) gadget_off(2,g13%()) gadget_off(2,g12%()) gadget_off(2,g11%()) gadget_off(2,g10%()) ENDIF ' IF calc_mode%>1 THEN gadget_off(2,g9%()) gadget_off(2,g8%()) ENDIF ' IF calc_mode%=2 THEN gadget_off(2,g7%()) gadget_off(2,g6%()) gadget_off(2,g5%()) gadget_off(2,g4%()) gadget_off(2,g3%()) gadget_off(2,g2%()) ENDIF ' IF calc_mode%<>0 THEN gadget_off(2,o13%()) ENDIF RETURN > PROCEDURE calculator_display(number,error%) ' ' Displays a number in the calculators display unless an arithmetic ' error has occured (ERROR<>0) in which case, an error message is displayed. ' An error code of -1, will not display anything, but will return the ' string of the number in the global string AIMEE$ ' LOCAL a$ ' prefix$="" IF number>=maxint% THEN error%=2 ENDIF ' IF error%<1 THEN SELECT calc_mode% CASE 0 IF floating_point! THEN IF floating_points%=0 THEN a$=STR$(number)+"." ELSE a$=TRIM$(STR$(number,20,MAX(floating_points%,0))) ENDIF ELSE a$=STR$(number) ENDIF CASE 1 a$=HEX$(number) prefix$="$" CASE 2 a$=BIN$(number) prefix$="%" CASE 3 a$=OCT$(number) prefix$="&O" ENDSELECT ELSE IF error%=1 a$=" Division By Zero " ELSE IF error%=2 a$=" Overflow " ENDIF ' IF error%<>-1 THEN colour2(2,col1%,col0%) a$=RIGHT$(SPACE$(20)+LEFT$(prefix$,1)+a$,20) text(2,40,28,a$) ELSE aimee$=TRIM$(a$) ENDIF RETURN > PROCEDURE test_button(keylist$,VAR gadget%()) ' ' Tests to see if a gadget has been activated either by clicking on or ' by pressing any of a number of keys listed in KEYLIST$. The routine ' will modify the global string BUTTON$ to the first letter in KEYLIST$ ' if the gadget was selected. ' LOCAL hit! ' IF key$="" THEN test_gadget(2,gadget%(),hit!) ENDIF ' IF hit! OR INSTR(keylist$,key$)<>0 THEN button$=LEFT$(keylist$,1) hit!=TRUE test_gadget_keypress(2,gadget%(),hit!) ENDIF RETURN > PROCEDURE get_calculator_key ' ' Test all gadgets on the calculator and returns a characters representing ' the one which was last pressed. It will also allow certain keypresses ' to select some gadgets as well. ' operation$="" REPEAT test_for_sleep(2) key$=UPPER$(event_key$) ' button$="" test_button("0",g0%()) test_button("1",g1%()) test_button("2",g2%()) test_button("3",g3%()) test_button("4",g4%()) test_button("5",g5%()) test_button("6",g6%()) test_button("7",g7%()) test_button("8",g8%()) test_button("9",g9%()) test_button("A",g10%()) test_button("B",g11%()) test_button("C",g12%()) test_button("D",g13%()) test_button("E",g14%()) test_button("F",g15%()) test_button(".",o13%()) test_button(CHR$(tab%),o14%()) ' test_button("S",o0%()) test_button("R",o1%()) test_button("^",o2%()) test_button(CHR$(8),o3%()) test_button("+",o4%()) test_button("-",o5%()) test_button("*X",o6%()) test_button("/%",o7%()) test_button("="+CHR$(13),o8%()) test_button("T",o9%()) test_button(CHR$(127),o10%()) test_button(helpkey$,o11%()) test_button(CHR$(27),o12%()) ' IF button$="T" THEN ! TOGGLE BASE calc_mode%=(calc_mode%+1) MOD 4 calculator_mode ' ELSE IF button$="S" ! STORE IN MEMORY calculator_memory=number(curr_number%) ' ELSE IF button$="R" ! RECALL FROM MEMORY number(curr_number%)=calculator_memory calculator_display(number(curr_number%),FALSE) ' ELSE IF button$=LEFT$(helpkey$,1) ! CE number(curr_number%)=0 floating_point!=FALSE calculator_display(number(curr_number%),FALSE) ' ELSE IF button$=CHR$(127) ! CA number(1)=0 number(2)=0 curr_number%=1 floating_point!=FALSE calculator_display(number(curr_number%),FALSE) ' ELSE IF INSTR(validop$,button$)<>0 ! +,-,x,/,^ IF INSTR(validop$+"=",last_button$)=0 IF curr_number%=2 THEN calculate(operation$) ELSE floating_point!=FALSE ENDIF ENDIF operation$=button$ number(2)=0 curr_number%=2 ' ELSE IF button$="=" ! = IF curr_number%=2 THEN calculate(operation$) ELSE calculator_display(number(curr_number%),FALSE) number(2)=0 ENDIF ' ELSE IF INSTR("0123456789ABCDEF.",button$)<>0 ! VALID DIGIT IF last_button$="=" THEN number(1)=0 number(2)=0 curr_number%=1 floating_point!=FALSE ENDIF calculator_display(number(curr_number%),-1) IF button$="." THEN IF INSTR(aimee$,button$)=0 AND LEN(aimee$)<13 THEN floating_point!=TRUE floating_points%=-1 ELSE button$="" ENDIF ENDIF ' new_number=VAL(prefix$+aimee$+button$) IF (LEN(aimee$)<20) AND button$<>"" AND ABS(new_number)=13) THEN IF floating_point! THEN ADD floating_points%,1 ENDIF ' number(curr_number%)=VAL(prefix$+aimee$+button$) calculator_display(number(curr_number%),FALSE) ENDIF ENDIF ' ELSE IF button$=CHR$(8) ! DELETE DIGIT calculator_display(number(curr_number%),-1) IF LEN(aimee$)>1 THEN aimee$=LEFT$(aimee$,LEN(aimee$)-1) number(curr_number%)=VAL(prefix$+aimee$) ELSE number(curr_number%)=0 ENDIF floating_points%=MAX(floating_points%-1,0) IF floating_points%=0 THEN floating_point!=FALSE ENDIF calculator_display(number(curr_number%),FALSE) ' ELSE IF button$=CHR$(tab%) ! +/- number(curr_number%)=-number(curr_number%) calculator_display(number(curr_number%),FALSE) ENDIF ' IF button$<>"" THEN last_button$=button$ ENDIF UNTIL button$=CHR$(27) OR abortgadget! RETURN > PROCEDURE calculator_mode ' ' Refreshes the calculator when the base is changed (e.g. Dec,Hex,Bin,Oct) ' calculator_display(number(curr_number%),FALSE) SELECT calc_mode% CASE 0 create_swirl_gadget(2,140,56,"@ DEC",o9%()) create_gadget(2,60,82,"@ 8 ",g8%()) create_gadget(2,100,82,"@ 9 ",g9%()) create_gadget(2,60,121,"@ . ",o13%()) CASE 1 create_swirl_gadget(2,140,56,"@ HEX",o9%()) create_gadget(2,20,56,"@ D ",g13%()) create_gadget(2,60,56,"@ E ",g14%()) create_gadget(2,100,56,"@ F ",g15%()) create_gadget(2,20,69,"@ A ",g10%()) create_gadget(2,60,69,"@ B ",g11%()) create_gadget(2,100,69,"@ C ",g12%()) CASE 2 create_swirl_gadget(2,140,56,"@ BIN",o9%()) gadget_off(2,g15%()) gadget_off(2,g14%()) gadget_off(2,g13%()) gadget_off(2,g12%()) gadget_off(2,g11%()) gadget_off(2,g10%()) gadget_off(2,g9%()) gadget_off(2,g8%()) gadget_off(2,g7%()) gadget_off(2,g6%()) gadget_off(2,g5%()) gadget_off(2,g4%()) gadget_off(2,g3%()) gadget_off(2,g2%()) CASE 3 create_swirl_gadget(2,140,56,"@ OCT",o9%()) create_gadget(2,60,108,"@ 2 ",g2%()) create_gadget(2,100,108,"@ 3 ",g3%()) create_gadget(2,20,95,"@ 4 ",g4%()) create_gadget(2,60,95,"@ 5 ",g5%()) create_gadget(2,100,95,"@ 6 ",g6%()) create_gadget(2,20,82,"@ 7 ",g7%()) ENDSELECT ' IF calc_mode%<>0 THEN floating_point!=FALSE gadget_off(2,o13%()) ENDIF ' IF NOT floating_point! THEN number(1)=INT(number(1)) number(2)=INT(number(2)) ENDIF RETURN > PROCEDURE mini_calc ' ' A very simple calculator function which offers *,/,+,- and ^ ' LOCAL validop$ ' validop$="+-/*^" curr_number%=1 old_keypad!=keypad! keypad!=TRUE ' DIM g0%(3),g1%(3),g2%(3),g3%(3),g4%(3),g5%(3),g6%(3),g7%(3),g8%(3),g9%(3),g10%(3),g11%(3) DIM g12%(3),g13%(3),g14%(3),g15%(3),o0%(3),o1%(3),o2%(3),o3%(3),o4%(3),o5%(3),o6%(3) DIM o7%(3),o8%(3),o9%(3),o10%(3),o11%(3),o12%(3),o13%(3),o14%(3) ' update_num_lock open_window(2,130,50,244,144,"Calculator") IF NOT unable_to_open_window! THEN ' ' draw the screen setup ' colour1(2,col0%) pbox(2,36,19,36+21*8,31) IF screencolours%>2 THEN draw_reverse_box(2,36,19,36+21*8,31) ELSE draw_box(2,36,19,36+21*8,31) ENDIF ' create_gadget(2,50,40,"@CA ",o10%()) create_gadget(2,100,40,"@CE ",o11%()) create_gadget(2,150,40,"@OFF",o12%()) create_gadget(2,140,69,"@STO",o0%()) create_gadget(2,180,69,"@RCL",o1%()) create_gadget(2,140,82,"@ ^ ",o2%()) create_gadget(2,180,82,"@ ",o3%()) calculator_gadgets calculator_mode ' ' Draw the Delete Digit arrowhead ' tabx%=193 taby%=91 line(2,tabx%,taby%-3,tabx%+14,taby%-3) pbox(2,tabx%+2,taby%-4,tabx%+3,taby%-2) pbox(2,tabx%+4,taby%-5,tabx%+5,taby%-1) pbox(2,tabx%+6,taby%-6,tabx%+7,taby%) ' create_gadget(2,140,95,"@ + ",o4%()) create_gadget(2,180,95,"@ - ",o5%()) create_gadget(2,140,108,"@ "+CHR$(215)+" ",o6%()) create_gadget(2,180,108,"@ "+CHR$(247)+" ",o7%()) create_gadget(2,140,121,"@ = ",o8%()) ' get_calculator_key ' keypad!=old_keypad! update_num_lock close_window(2) ENDIF ' ERASE g0%(),g1%(),g2%(),g3%(),g4%(),g5%(),g6%(),g7%(),g8%(),g9%(),g10%(),g11%() ERASE g12%(),g13%(),g14%(),g15%(),o0%(),o1%(),o2%(),o3%(),o4%(),o5%(),o6%() ERASE o7%(),o8%(),o9%(),o10%(),o11%(),o12%(),o13%(),o14%() RETURN ' ************************ USER COMMAND ROUTINES ***************************** > PROCEDURE save_last_command ' ' Writes the current command which the user has been editing, from its ' temporary storage, into the array for User Commands. This is performed ' just before the user moves onto another User Command for editting in the ' Define Commands window. ' command$(currcom%-1)=command$ commenu$(currcom%-1)=menuent$ autosave!(currcom%-1)=autosave! delay!(currcom%-1)=delay! customwin!(currcom%-1)=customwin! RETURN > PROCEDURE command_gadgets(choice%) create_swirl_gadget(2,202,77,"@ Command "+STR$(choice%),co1%()) ' currcom%=choice% command$=command$(currcom%-1) menuent$=TRIM$(commenu$(currcom%-1)) autosave!=autosave!(currcom%-1) delay!=delay!(currcom%-1) customwin!=customwin!(currcom%-1) ' show_switch(2,delay!,290,64,gad3%()) show_switch(2,autosave!,155,64,gad4%()) show_switch(2,customwin!,155,77,gad2%()) refresh_string(2,163,42,19,command$) refresh_string(2,163,57,19,menuent$) RETURN > PROCEDURE command2menu(numb%,comm$) LOCAL menuno% ' comm$=TRIM$(comm$) menuno%=numb%-1 IF comm$="" THEN comm$=TRIM$(commenu$(menuno%)) IF comm$="" THEN comm$="User Command "+STR$(numb%) ENDIF ENDIF commenu$(menuno%)=comm$ menu_text(5,6+menuno%,comm$) RETURN > PROCEDURE define_commands ' ' Define the user command and all of its options ' open_window(2,120,30,375,200,"Define User Commands") IF NOT unable_to_open_window! THEN draw_box(2,30,23,340,92) draw_box(2,30,106,340,163) heading(2,385,26,"Definitions") text(2,50,43," Command :") text(2,50,58,"Menu Entry :") text(2,50,73," AutoSave : Delay : ") text(2,50,86,"Custom CLI :") heading(2,385,109,"CLI Window") text(2,50,125,"Window Title :") text(2,50,140," Position :") text(2,50,155," Dimensions :") create_gadget(2,32,174,accept$,gad1%()) create_gadget(2,265,174,"SET DIR",gad5%()) command_gadgets(1) refresh_string(2,174,125,18,clititle$) refresh_string(2,174,140,4,clix$) refresh_string(2,224,140,4,cliy$) refresh_string(2,174,155,4,cliw$) refresh_string(2,224,155,4,clih$) casepos%=0 userquit!=FALSE ' REPEAT string_group(2,163,42,19,160,0,casepos%,command$,move%) string_group(2,163,57,19,17,1,casepos%,menuent$,move%) string_group(2,174,125,18,40,2,casepos%,clititle$,move%) string_group(2,174,140,4,3,3,casepos%,clix$,move%) string_group(2,224,140,4,3,4,casepos%,cliy$,move%) string_group(2,174,155,4,3,5,casepos%,cliw$,move%) string_group(2,224,155,4,3,6,casepos%,clih$,move%) ' IF move%=2 THEN ! Return pressed IF casepos%<=1 AND currcom%<3 THEN @save_last_command command_gadgets(currcom%+1) move%=0 ELSE userquit!=TRUE ENDIF ENDIF casepos%=(casepos%+move%+7) MOD 7 ' ' Test for a click on one of the gadgets ' test_gadget(2,gad2%(),click!) IF click! AND dosstart! THEN ! CUSTOM CLI customwin!=NOT customwin! show_switch(2,customwin!,155,77,gad2%()) ENDIF ' test_gadget(2,gad4%(),click!) IF click! THEN ! AUTO SAVE autosave!=NOT autosave! show_switch(2,autosave!,155,64,gad4%()) ENDIF ' test_gadget(2,gad3%(),click!) ! RETURN DELAY PROMPT IF click! THEN delay!=NOT delay! show_switch(2,delay!,290,64,gad3%()) ENDIF ' test_gadget(2,gad5%(),click!) ! SET DEFAULT DIR IF click! THEN define_command_path activate(2) ENDIF ' test_gadget(2,co1%(),click!) ! COM1 IF click! THEN @save_last_command command_gadgets((currcom% MOD 3)+1) ENDIF test_gadget(2,gad1%(),okay!) ' ' Check that the Custom CLI window coordinates make sense. ' quantize(500,clix$) quantize(200,cliy$) quantize(640-VAL(clix$),cliw$) quantize(wbench_size%-VAL(cliy$),clih$) UNTIL abortgadget! OR okay! OR userquit! test_gadget_keypress(2,gad1%(),userquit!) ' @save_last_command close_window(2) command2menu(1,"") command2menu(2,"") command2menu(3,"") ENDIF ' RETURN > PROCEDURE define_command_path ' ' Lets the user define the default directory which will be ' used by all of the user commands. ' LOCAL a$ ' open_window(3,130,50,350,65,"Default Directory For User Command") IF NOT unable_to_open_window! THEN ' colour2(3,pen1%,backcol%) text(3,30,28,"Path Name :") create_gadget(3,20,40,accept$,okay2%()) create_gadget(3,262,40,cancel$,cancel2%()) a$=command_path$ REPEAT string_gadget(3,132,28,23,120,a$,dummy%) test_gadget(3,okay2%(),okay!) test_gadget(3,cancel2%(),cancel!) ' IF dummy%=2 THEN okay!=TRUE ENDIF UNTIL okay! OR cancel! OR abortgadget! test_gadget_keypress(3,okay2%(),okay!) close_window(3) ' IF okay! THEN command_path$=TRIM$(a$) ENDIF ENDIF ' RETURN > PROCEDURE execute(comno%) ' ' Executes one of the 3 user commands, opening a Custom CLI if Delay! is set. ' If AutoSave! is set, then the current document is saved beforehand ' COMNO can take the value 1..3 depending upon which command is to be run. ' LOCAL command$,a$,l%,x% ' com$=command$(comno%-1) autosave!=autosave!(comno%-1) delay!=delay!(comno%-1) customwin!=customwin!(comno%-1) execute_ok!=TRUE ' IF TRIM$(com$)<>"" THEN IF INSTR(com$,"*")>0 AND curfilename$="" inform("Current File Has No Filename!|Please Save It First") ELSE IF autosave! THEN IF docupdated! OR lineupdated! THEN @save_file(FALSE) ENDIF ENDIF ' ' Has the user specified a default directory? ' banner("Executing User Command "+STR$(comno%)) IF command_path$<>"" THEN set_current_dir(command_path$) ENDIF ' ' Check for occurences of "*", "@", "|" or PI characters ' within the command string and convert them to the supported ' strings. (filename, line feed, directory name) ' split_filename(curfilename$,temppath$,x$) command$="" FOR l%=1 TO LEN(com$) a$=MID$(com$,l%,1) IF a$="|" THEN a$=CHR$(lf%) ENDIF ' IF a$="*" THEN command$=command$+curfilename$ ELSE IF a$="@" x%=RINSTR(curfilename$,".") IF x%>0 THEN command$=command$+LEFT$(curfilename$,x%-1) ELSE command$=command$+temppath$+"a.out" ENDIF ELSE IF a$=CHR$(182) command$=command$+temppath$ ELSE command$=command$+a$ ENDIF NEXT l% ' IF LEN(command$)<256 THEN ' IF use_wbench! THEN ~WindowToBack(winptr%(0)) ELSE ~WBenchToFront() ENDIF ' set_pointer(1) IF customwin! THEN ' ' This is the routine which is used if the user has specified ' that he wants a CUSTOM CLI window for the command to be run ' from. There is a bit of playing around with task structures ' which is done to make the window have a standard input channel. ' process%=FindTask(0) ! Get process structure pr_consoletask%={process%+164} ! Save pr_ConsoleTask pr_cis%={process%+156} ! Save pr_CIS pr_cos%={process%+160} ! Save pr_COS ' com$=command$+CHR$(0) con$="CON:"+clix$+"/"+cliy$+"/"+cliw$+"/"+clih$+"/"+clititle$+CHR$(0) lock%=Open(V:con$,1005) IF lock%<>0 THEN ' ' Try and open the Standard Ouput channel ' stdout$="*"+CHR$(0) stdout%=Open(V:stdout$,1005) ' LPOKE process%+164,{SHL(lock%,2)+8} ! pr_ConsoleTask=fhp->fh_Type LPOKE process%+156,lock% ! pr_CIS = (BPTR) lock LPOKE process%+160,stdout% ! pr_COS = (BPTR) stdout ' execute_ok!=Execute(V:com$,0,lock%) delay_return(delay!) ' ~Close(lock%) IF stdout%<>0 THEN ~Close(stdout%) ENDIF ' LPOKE process%+164,pr_consoletask% LPOKE process%+156,pr_cis% LPOKE process%+160,pr_cos% ENDIF ELSE ' ' This is the bit which is used if the user has not selected ' a custom window for the command output. i.e. the DEFAULT CLI ' is being used for output. ' execute_ok!=EXEC(command$,-1,-1) delay_return(delay!) ENDIF set_pointer(0) ' IF use_wbench! THEN ~WindowToFront(winptr%(0)) ELSE ~ScreenToFront(scrptr%(1)) ENDIF ~ActivateWindow(winptr%(0)) ' ELSE request("SORRY - That User Command Is Over 256 Characters !","WHAT A SACK OF SHIT!","",x%) ENDIF ' IF command_path$<>"" THEN set_current_dir(defaultdir$) ENDIF close_banner ' IF NOT execute_ok! THEN inform("Could Not Execute User Command!|Please Check That You Have The|'Run' Command In C: (Or Resident)") ENDIF ' ENDIF ELSE request("User Command "+STR$(comno%)+" Is Undefined!|Please Use `Define Commands' First","TA VERY MUCH","",x%) ENDIF ignore_messages RETURN ' ******************* PRINTING UTILITIES / PROCEDURES *********************** > PROCEDURE printer_init ' ' Sends any initial codes to the printer before the main text is printed. ' Codes include NLQ on/off; pitch (pica,elite,cond) and the user's own ' code string. If there was an error, then the flag PRINTERERROR! is ' updated to this effect. ' LOCAL code$,lock%,on_line! ' printer_message("Initialising Printer ...") ' LET printererror!=FALSE is_printer_online(on_line!) IF on_line! THEN prtname$=prtdevice$+CHR$(0) ! Name of printer for output code$="" ' ' >>> SET THE LEFT & RIGHT MARGINS <<< ' code$=code$+CHR$(27)+"["+STR$(left_margin%)+";"+STR$(right_margin%)+"s" ' ' >>> TURN ON THE APPROPRIATE PITCH <<< ' SELECT pitch% CASE 0 code$=code$+CHR$(27)+"[0w" CASE 1 code$=code$+CHR$(27)+"[2w" CASE 2 code$=code$+CHR$(27)+"[4w" ENDSELECT ' ' >>> TURN NLQ ON/OFF <<< ' IF nlq! THEN code$=code$+CHR$(27)+"[2"+CHR$(34)+"z" ELSE code$=code$+CHR$(27)+"[1"+CHR$(34)+"z" ENDIF ' ' >>> USER INITIALISE CODE <<< ' create_hex_string(setup$,init$) code$=code$+init$ ' lock%=Open(V:prtname$,mode_new%) IF lock%<>0 THEN status%=Write(lock%,V:code$,LEN(code$)) ~Close(lock%) IF status%<0 THEN LET printererror!=TRUE ENDIF ELSE LET printererror!=TRUE ENDIF ELSE inform("Printer Is Not On-Line !") LET printererror!=TRUE ENDIF RETURN > PROCEDURE print_document(title$,start_add%,noofbytes%) ' ' Option to print the current document. ' Facility to turn on or off NLQ (if available) and to select the ' pitch size for the printed text (pica,elite or condensed) ' LOCAL a$,cancel!,pitch! ' ' Check to see if this option was called from an ARexx command ... ' IF arexx_command! THEN print_range(start_add%,noofbytes%) ELSE open_window(2,120,30,410,198,title$) IF NOT unable_to_open_window! THEN draw_box(2,30,26,374,109) draw_box(2,30,115,374,161) colour2(2,pen2%,backcol%) ' a$=SPACE$(232) ~GetDefPrefs(V:a$,232) FOR l%=0 TO 20 b$=MID$(a$,129+l%,1) EXIT IF b$=CHR$(0) text(2,159+l%*8,143,b$) ! Display default printer NEXT l% ' printer_message("Waiting For User") colour1(2,pen1%) heading(2,410,29,"Print Options") text(2,45,45," Left Marg : NLQ Font :") text(2,45,59,"Right Marg : Single Sht :") text(2,45,73," Page Size : Page Nos :") text(2,45,87,"Start Page : Line Wrap :") text(2,45,101," T/B Margs : Pitch :") text(2,45,129,"Init String :") text(2,45,143," Printer :") text(2,45,155," Status :") ' create_gadget(2,326,172,"DONE",gad2%()) ghost_gadgets(0) ' refresh_number(2,156,59,4,right_margin%) refresh_number(2,156,73,4,page_length%) refresh_number(2,156,87,4,start_page%) refresh_number(2,156,101,4,tb_margin%) refresh_string(2,165,129,21,setup$) casepos%=0 ' REPEAT ' IF pitch! THEN SELECT pitch% CASE 0 create_swirl_gadget(2,275,92,"@PICA ",pitch%()) CASE 1 create_swirl_gadget(2,275,92,"@ELITE ",pitch%()) CASE 2 create_swirl_gadget(2,275,92,"@COND ",pitch%()) ENDSELECT ENDIF ' number_group(2,156,45,4,3,0,casepos%,left_margin%,exit%) number_group(2,156,59,4,3,1,casepos%,right_margin%,exit%) number_group(2,156,73,4,3,2,casepos%,page_length%,exit%) number_group(2,156,87,4,3,3,casepos%,start_page%,exit%) number_group(2,156,101,4,3,4,casepos%,tb_margin%,exit%) string_group(2,165,129,21,40,5,casepos%,setup$,exit%) ' ' Make sure that the values enter make sense ' page_length%=MIN(MAX(page_length%,5),999) right_margin%=MAX(right_margin%,10) left_margin%=MIN(left_margin%,right_margin%-1) tb_margin%=MAX(MIN(tb_margin%,(page_length%-10) DIV 2),0) create_hex_string(setup$,x$) ' ' Refresh the gadget's contents ' SELECT casepos% CASE 0 refresh_number(2,156,45,4,left_margin%) CASE 1 refresh_number(2,156,45,4,left_margin%) refresh_number(2,156,59,4,right_margin%) CASE 2 refresh_number(2,156,73,4,page_length%) refresh_number(2,156,101,4,tb_margin%) CASE 3 refresh_number(2,156,87,4,start_page%) CASE 4 refresh_number(2,156,101,4,tb_margin%) CASE 5 refresh_string(2,165,129,21,setup$) ENDSELECT ' ' Deal with a click on a gadget ... ' casepos%=(casepos%+exit%+6) MOD 6 test_printer_gadgets test_gadget(2,nlq%(),test!) ! NLQ FONT IF test! THEN nlq!=NOT nlq! show_switch(2,nlq!,323,45-9,nlq%()) ENDIF ' test_gadget(2,pitch%(),pitch!) ! PRINT PITCH IF pitch! THEN prev_pitch%=10+(pitch%*2.5)+(pitch% DIV 2)*2 pitch%=(pitch%+1) MOD 3 curr_pitch%=10+(pitch%*2.5)+(pitch% DIV 2)*2 right_margin%=left_margin%+ROUND((curr_pitch%*(right_margin%-left_margin%))/prev_pitch%) refresh_number(2,156,59,4,right_margin%) ENDIF ' IF eject! THEN eject_page ENDIF ' IF okay! THEN print_range(start_add%,noofbytes%) ENDIF ' IF exit%=2 THEN cancel!=TRUE ENDIF UNTIL cancel! OR abortgadget! test_gadget_keypress(2,gad2%(),cancel!) close_window(2) ENDIF ENDIF RETURN > PROCEDURE print_range(print_add%,bytes%) ' ' Do the actual printing of the document and display any errors encountered ' LOCAL lock%,print_line%,print_page%,end_add%,print_text$,linelength%,userabort!,laura% ' @printer_init print_line%=1 print_page%=start_page% linelength%=right_margin%-left_margin% end_add%=print_add%+bytes% done_printing!=FALSE print_text$="" ' ' Now print the actual text ... ' IF NOT printererror! THEN ghost_gadgets(1) lock%=Open(V:prtname$,mode_new%) ' REPEAT test_events(2) ' ' Then check to see if the user has clicked over the STOP! gadget ' or the CANCEL gadget. ' test_gadget(2,gad1%(),userabort!) test_gadget(2,gad2%(),cancel!) IF cancel! OR abortgadget! THEN userabort!=TRUE ENDIF ' ' Add the bottom margin if at the bottom of the page ' IF print_line%=page_length%-tb_margin%+1 THEN curr_line_text$=STRING$(tb_margin%,CHR$(lf%)) print_line%=print_line%+tb_margin% IF curr_line_text$<>"" THEN IF Write(lock%,V:curr_line_text$,LEN(curr_line_text$))<0 THEN LET printererror!=TRUE ENDIF ENDIF ENDIF ' ' Wait for a gadget to be hit if at end of page and single sheet mode on ' IF print_line%>page_length% THEN IF manual_feed! AND (NOT arexx_command!) THEN printer_message("Ready For New Page ...") ghost_gadgets(2) REPEAT test_for_sleep(2) test_printer_gadgets IF eject! THEN eject$=CHR$(12) IF Write(lock%,V:eject$,1)<0 THEN LET printererror!=TRUE ENDIF ENDIF IF cancel! THEN userabort!=TRUE ENDIF ' IF event_key$=CHR$(13) THEN okay!=TRUE ELSE IF event_key$=CHR$(27) OR abortgadget! userabort!=TRUE ENDIF UNTIL okay! OR userabort! test_gadget_keypress(2,gad1%(),okay!) ghost_gadgets(1) ENDIF printer_message("") print_line%=1 print_page%=print_page%+1 ENDIF ' ' Put the current page number at bottom if requested to do so ' IF (print_line%=page_length%-1-tb_margin%) AND (page_nos!) THEN print_text$=pageno_style$ REPEAT laura%=INSTR(UPPER$(print_text$),UPPER$(pageno_symbol$)) IF laura%>0 THEN print_text$=LEFT$(print_text$,laura%-1)+STR$(print_page%)+RIGHT$(print_text$,LEN(print_text$)-1-laura%) ENDIF UNTIL laura%=0 print_text$=CHR$(lf%)+SPACE$((linelength%-LEN(print_text$)) DIV 2)+print_text$ print_line%=print_line%+2 IF (print_add%>end_add%) THEN done_printing!=TRUE ENDIF ELSE ' ' Otherwise, get the next line of text from memory to be printed ' (unless we are still printing the overflow from a previous line.) ' IF print_text$="" THEN printer_message("Printing Line "+STR$(print_line%)+"/Page "+STR$(print_page%)) IF (print_add%>=end_add%) THEN print_text$="" ELSE convert_line(print_add%,0,print_text$) IF NOT linewrap! THEN print_text$=LEFT$(print_text$,linelength%) ENDIF ENDIF next_line(print_add%) ENDIF print_line%=print_line%+1 ENDIF ' ' And finally print the current line of text ' IF NOT userabort! THEN curr_line_text$=LEFT$(print_text$,linelength%)+CHR$(lf%) ' ' Print the top margin if at top of a page ' IF print_line%-1=1 THEN FOR laura%=1 TO tb_margin% curr_line_text$=CHR$(lf%)+curr_line_text$ print_line%=print_line%+1 NEXT laura% ENDIF ' ' Print the text ' IF Write(lock%,V:curr_line_text$,LEN(curr_line_text$))<0 THEN LET printererror!=TRUE ENDIF ' ' Deal with overflowing lines ' IF LEN(print_text$)>linelength% THEN print_text$=RIGHT$(print_text$,LEN(print_text$)-linelength%) ELSE print_text$="" ENDIF ENDIF ' ' Are we finished printing yet? ' IF (print_add%>end_add%) AND (NOT page_nos!) AND print_text$="" done_printing!=TRUE ENDIF UNTIL printererror! OR done_printing! OR userabort! ' ~Close(lock%) ghost_gadgets(0) ENDIF ' ' Check for any errors (display appropriate message) ' IF userabort! OR abortgadget! THEN printer_message("User Abort") ELSE IF NOT printererror! THEN printer_message("Waiting For User") ELSE printer_message("Printer Error !") ENDIF ENDIF RETURN > PROCEDURE test_printer_gadgets ' ' Checks to see if one of the gadgets on the printer window has been ' clicked and takes appropriate action. The gadgets which are detected ' here can be changed before and during printing. ' ' If PRINT/STOP was clicked, then OKAY!=TRUE ' If CANCEL was clicked then CANCEL!=TRUE ' test_gadget(2,man%(),test!) ! MANUAL FEED IF test! THEN manual_feed!=NOT manual_feed! show_switch(2,manual_feed!,323,59-9,man%()) ENDIF ' test_gadget(2,pnos%(),test!) ! PAGE NOS. IF test! THEN page_nos!=NOT page_nos! show_switch(2,page_nos!,323,73-9,pnos%()) ENDIF ' test_gadget(2,wrap%(),test!) ! LINE WRAP IF test! THEN linewrap!=NOT linewrap! show_switch(2,linewrap!,323,87-9,wrap%()) ENDIF ' test_gadget(2,gad1%(),okay!) ! PRINT/STOP! test_gadget(2,eject%(),eject!) ! EJECT PAGE test_gadget(2,gad2%(),cancel!) ! CANCEL RETURN > PROCEDURE get_printer_defaults ' ' Looks at the current printer preferences to get the default values ' for EdWords left/right margins and page sizes and whether or not ' manual feed is to be employed. ' LOCAL prefbuf%,prefsize% ' prefsize%=182 prefbuf%=AllocMem(prefsize%,1) IF prefbuf%<>0 THEN ~GetDefPrefs(prefbuf%,prefsize%) left_margin%=CARD{prefbuf%+164} ! Get left margin right_margin%=CARD{prefbuf%+166} ! Get right margin page_length%=CARD{prefbuf%+178} ! Get Page Length IF CARD{prefbuf%+180}=128 THEN ! Get Single/Fanfold sheet manual_feed!=TRUE ELSE manual_feed!=FALSE ENDIF ~FreeMem(prefbuf%,prefsize%) ELSE left_margin%=5 right_margin%=75 page_length%=66 manual_feed!=TRUE ENDIF ' IF manual_feed! THEN tb_margin%=0 ! no Top/Bottom margins if Single Sht ELSE tb_margin%=2 ! 2 lines margin if tractor paper ENDIF page_nos!=FALSE ! no page numbers by default setup$="" ! no printer init string nlq!=FALSE ! if true, then print in NLQ font pitch%=0 ! 0=Pica, 1=Elite, 2=Condensed start_page%=1 ! Page numbering begins at 1 pageno_style$="Page "+pageno_symbol$ ! Default page no. style = `Page 1' RETURN > PROCEDURE eject_page ' ' Sends a Form Feed character to the printer ' LOCAL code$ ' is_printer_online(on_line!) IF on_line! THEN code$=CHR$(12) ! Form Feed character code prtname$=prtdevice$+CHR$(0) ! Name of printer for output lock%=Open(V:prtname$,mode_new%) IF lock%<>0 THEN status%=Write(lock%,V:code$,1) ~Close(lock%) ENDIF ELSE inform("Printer Is Not On-Line !") ENDIF RETURN > PROCEDURE printer_message(text$) ' ' Displays a message in the Status field of the Print Options window ' IF NOT arexx_command! THEN colour2(2,pen2%,backcol%) text(2,159,155,LEFT$(text$+SPACE$(26),26)) ENDIF RETURN > PROCEDURE ghost_gadgets(mode%) ' ' 0 = All gadgets selectable (none ghosted) = initial mode ' 1 = Stop,Eject,Done selectable (others ghosted) = printing mode ' 2 = as 1 + Man Feed, Single Sht, Line Wrap = Waiting for page mode ' IF mode%=0 OR mode%=2 THEN create_gadget(2,30,172,"PRINT",gad1%()) create_gadget(2,96,172,"EJECT",eject%()) ELSE create_gadget(2,30,172,"STOP!",gad1%()) gadget_off(2,eject%()) ENDIF ' IF mode%=0 THEN show_switch(2,nlq!,323,45-9,nlq%()) pitch!=TRUE ELSE IF mode%=1 gadget_off(2,nlq%()) gadget_off(2,pitch%()) ENDIF ' IF mode%=0 OR mode%=2 THEN show_switch(2,manual_feed!,323,59-9,man%()) show_switch(2,page_nos!,323,73-9,pnos%()) show_switch(2,linewrap!,323,87-9,wrap%()) ELSE gadget_off(2,man%()) gadget_off(2,pnos%()) gadget_off(2,wrap%()) ENDIF ' RETURN ' *********************** PRINTER.DEVICE ROUTINES *************************** > PROCEDURE is_printer_online(VAR online!) ' ' This procedure checks to see if the printer is on-line. The result ' of the check is returned in the boolean ONLINE!. (N.B. If any errors ' occur during the process, then online! will be set to TRUE). ' This is done by opening the printer.device and sending a PRD_QUERY ' command to get the current printer status. Bit 0 of this status ' byte states whether the printer is on or off line. ' LOCAL devname$,prtport%,request% ' online!=TRUE ' IF UPPER$(prtdevice$)="PRT:" THEN ! AND (NOT workbench_2.0!) ' ' Create a MessagePort which will be used for an message reports. ' This structure acts as an anchor point for device communication. ' prtport%=CreatePort(0,0) IF prtport%<>0 THEN ' ' Create a device request structure and initialise it. ' This is the structure which controlls the device. ' request%=CreateExtIO(prtport%,62) IF request%<>0 THEN ' ' Open the printer.device using the device request structure ' which has been allocated and initialised. ' devname$="printer.device"+CHR$(0) IF OpenDevice(V:devname$,0,request%,0)=0 THEN ' ' Set up the IOStdReq structure to send the PRD_QUERY command ' DPOKE request%+28,12 ! io_Command = PRD_QUERY LPOKE request%+40,0 ! io_Data = Pointer to status buffer ' ' Send the command to the printer.device with the DoIo() call ' ~DoIO(request%) ' ' Only check to see if on-line if the io_Actual longword ' states that the device is a parallel device (1) and not ' a serial one (2) ' IF LPEEK(request%+32)=1 THEN ' ' Check Bit 0 of the status byte to see if the printer is on-line ' This byte is pointed to by the io_Data filed of the IOStdReq ' IF BTST(PEEK({request%+40}),0) THEN online!=FALSE ENDIF ENDIF ~CloseDevice(request%) ELSE inform("Cannot Access The Printer!|Device Is Locked Out, or|devs:printer.device Not Present.") ENDIF delete_ext_io(request%,62) ENDIF ~DeletePort(prtport%) ENDIF ENDIF RETURN > PROCEDURE delete_ext_io(iorequest%,size%) ' ' This routine releases a device block which has been allocated by ' the CreateExtIO() call. For some reason, GFA-Basic offers the Create ' routine but not the Delete one - wierd eh! Anyway, I have written it ' myself, converted from the original C source code of the Exec ' support library. ' ' IORequest = Address of the IORequest structure (returned by CreateExtIO()) ' Size = The size of the custom device block ' IF iorequest%<>0 THEN ' ' Mutilate the IORequest so that further use is impossible. ' (This effectively disconnects the device block) ' POKE iorequest%+8,&HFF ! IORequest->io_Message.mn_Node.ln_Type=0xff LPOKE iorequest%+20,-1 ! IORequest->io_Device=(struct Device *)-1 LPOKE iorequest%+24,-1 ! IORequest->io_Unit=(struct Unit *)-1 ' ' Return the memory which was allocated for the device block ' ~FreeMem(iorequest%,size%) ENDIF RETURN ' ************************* COMMAND LINE OPTIONS **************************** > PROCEDURE check_command_tail ' ' Work out what options the user has selected from the command line ' of the CLI when he called the program. Current options :- ' ' -C = specify a configuration file to load in ' -NOC = supresses loading of any configuration file ' -COLS = number of colours for custom screen (2 or 4) ' ? = prints the command line options ' LOCAL x% commandtail$=_dosCmd$ extract_option("-COLS",FALSE,commandtail$,noofcolours$,setnoofcolours!) extract_option("-NOC",TRUE,commandtail$,dummy$,no_configfile!) extract_option("-C",FALSE,commandtail$,configdir$,gotit!) extract_option("?",TRUE,commandtail$,dummt$,helptext!) ' IF INSTR(configdir$,":")=0 THEN ! expand filename configdir$=defaultdir$+TRIM$(configdir$) ! to full path ENDIF ' ' Strip filename "EdWord.config" if supplied with the -C option ' IF UPPER$(RIGHT$(configdir$,LEN(configfile$)))=UPPER$(configfile$) THEN configdir$=LEFT$(configdir$,LEN(configdir$)-LEN(configfile$)) ENDIF ' strip_inverted_commas(commandtail$) ' ' Display the help text if requested. ' IF helptext! THEN infoprint("") infoprint("EdWord V"+version$+" Text Editor - "+author$+", 1994.") infoprint("~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~") infoprint(" Usage : EdWord {filename} {-C configdir} {-NTSC} {-WB} {-LACE} {-VI} {-EOL}") infoprint(" {-NODIR} {-MEM size} {-T title} {-F fontname} {-D} {-REQ}") infoprint(" {-XICON} {-COLS number} {-H height} {-Y ycoord} {-L line}") infoprint(" {-UL size} {-ND} {-AREXX script} {-MOD text} {-ARP} {-ASL}") infoprint(" {-PUB pubscreenname} {-PCOFF} {-NOC} {-ZOOM}") infoprint("") infoprint(" Where, -C loads an EdWord configuration file from specified dir.") infoprint(" -WB forces EdWord to use the WorkBench screen.") infoprint(" -NTSC forces EdWord into an NTSC screen mode on start up.") infoprint(" -NODIR file requester will initially list all mounted devices.") infoprint(" -LACE forces EdWord to use an interlaced screen.") infoprint(" -MEM specifies the memory buffer size in bytes (default=60000).") infoprint(" -VI starts EdWord up in vi emulation mode (for Unix users)") infoprint(" -T changes the program title (default EdWord V"+version$+").") infoprint(" -F uses the specified 8x8 point font (default topaz 80).") infoprint(" -D disables checks for viruses in RAM - best left on !") infoprint(" -UL specifies the size of the underscore cursor (1 or 2)") infoprint(" -REQ forces a file requester on start up.") infoprint(" -ASL makes EdWord use the asl.library file requester") infoprint(" -COLS defines the number of colours for the screen (2 or 4)") infoprint(" -AREXX runs an ARexx script file on start up.") infoprint(" -MOD defines a piece of text to mark an updated file (e.g. "+")") infoprint(" -EOL Cursor left & right can overflow onto previous/next line") infoprint(" -H the height of the initial window/screen (in pixels)") infoprint(" -Y the y-coordinate of the top edge of window (in pixels)") buggeroff!=TRUE ENDIF RETURN > PROCEDURE use_command_tail ' ' Work out what options the user has selected from the command line ' of the CLI when he called the program. Current options :- ' ' -NTSC = force the program to open with an NTSC (640x200) window ' -LACE = force an interlace screen ' -WB = force the program to open on the workbench ' -WB2.0 = acts as if operating under WBench 2.0 (option not documented) ' -MEM = defines the default document buffer size in bytes ' -T = specifies the default screen/window title (EdWord V2.1) ' -F = loads the specified (8 point) font for use by the editor ' -REQ = forces the file requester as soon as EdWord opens ' -D = disable virus checking on start up ' -NODIR = file requester will not list current directly until specifically ' told to do so. ' -XICON = Used when EdWord is run from workbench with XIcon ' -H = Number of text lines in window (height in pixels) ' -Y = The y-coordinate of the top edge of window (in pixels) ' -L = Make editor jump to a specified line number on load up ' -VI = emulates VI editor (makes screen flash when you press a key!) ' -AREXX = runs an ARexx script on start up. ' -ND = turns of keyboard damping ' -AC = Alternative Cursor colours ' -UL = Use an underline cursor instead of a block ' -EOL = Cursor left & right can overflow onto previous/next line ' -MOD = defines the modified text used on the editor's title bar ' -ARP = use the arp.library file requester ' -ASL = use the asl.library file requester ' LOCAL x% extract_option("-XICON",TRUE,commandtail$,dummy$,xicon!) extract_option("-AREXX",FALSE,commandtail$,initial_arexx$,initial_arexx!) extract_option("-NODIR",TRUE,commandtail$,dummy$,nodir!) extract_option("-PCOFF",TRUE,commandtail$,dummy$,pcoff!) extract_option("-NTSC",TRUE,commandtail$,dummy$,force_ntsc!) extract_option("-LACE",TRUE,commandtail$,dummy$,force_lace!) extract_option("-ZOOM",TRUE,commandtail$,dummy$,force_zoom!) extract_option("-MEM",FALSE,commandtail$,memorysize$,usermem!) extract_option("-PUB",FALSE,commandtail$,userpubname$,userpubname!) extract_option("-REQ",TRUE,commandtail$,dummy$,forcerequester!) extract_option("-ARP",TRUE,commandtail$,dummy$,force_arp!) extract_option("-ASL",TRUE,commandtail$,dummy$,force_asl!) extract_option("-EOL",TRUE,commandtail$,dummy$,eol_overflow!) extract_option("-MOD",FALSE,commandtail$,modified_text$,modified_text!) extract_option("-VI",TRUE,commandtail$,dummy$,vi_mode!) extract_option("-UL",FALSE,commandtail$,ulparam$,size_underline!) extract_option("-ND",TRUE,commandtail$,dummy$,no_damping!) extract_option("-WB",TRUE,commandtail$,dummy$,force_wbench!) extract_option("-T",FALSE,commandtail$,screenname$,x!) extract_option("-F",FALSE,commandtail$,deffont$,x!) extract_option("-D",TRUE,commandtail$,dummy$,disablevcheck!) extract_option("-H",FALSE,commandtail$,custom_size$,custom_size2!) extract_option("-Y",FALSE,commandtail$,window_ycoord$,custom_ycoord2!) extract_option("-L",FALSE,commandtail$,jump_line$,immediate_jump!) ' strip_inverted_commas(commandtail$) ' ' Check for -MEM option ' IF usermem! THEN ' check that memory size is within acceptable range memorysize$=LEFT$(STR$(MAX(VAL(memorysize$),10000)),8) ENDIF ' IF wbench! THEN ! validate NoOfColours setnoofcolours!=FALSE ENDIF ' lower(deffont$) ! font should be lcase IF RIGHT$(deffont$,5)=".font" THEN ! remove ".font" deffont$=LEFT$(deffont$,LEN(deffont$)-5) ENDIF ' screenname$=LEFT$(screenname$,40) ! 40=max title length ' IF custom_size2! THEN custom_size%=VAL(custom_size$) custom_size!=TRUE ENDIF IF custom_ycoord2! THEN window_ycoord%=VAL(window_ycoord$) custom_ycoord!=TRUE ENDIF ' ' Check for -UL option for underscore cursor ' underline_size%=2 IF size_underline! THEN underline_size%=MIN(MAX(VAL(ulparam$),1),2) ENDIF ' ' Check for the -VI option and change the screen title if found ' IF vi_mode! THEN screenname$="VI Emulator" ENDIF ' IF INSTR(commandtail$,":")=0 THEN ! expand filename commandtail$=defaultdir$+commandtail$ ! to full path ENDIF RETURN > PROCEDURE extract_option(opt$,notext!,VAR x$,value$,found!) ' ' opt$ = option identifier e.g. "-C" ' notext! = if TRUE then there is no text after the option id. e.g. -NTSC ' x$ = command tail ' value$ = text after option id ' found! = TRUE if option found ' LOCAL x%,y%,optend$ ' opt$=" "+opt$ x$=" "+x$ found!=FALSE IF UPPER$(x$)=UPPER$(opt$) THEN found!=TRUE x$="" ELSE x%=INSTR(UPPER$(x$),UPPER$(opt$)) IF x%>0 THEN found!=TRUE IF NOT notext! THEN y%=x%+LEN(opt$) WHILE MID$(x$,y%,1)=" " ! ignore spaces after option y%=y%+1 WEND ' y1%=y% IF MID$(x$,y%,1)=CHR$(34) THEN ! test for inverted commas optend$=CHR$(34) y1%=y1%+1 ELSE optend$=" " ENDIF ' y2%=INSTR(x$,optend$,y1%) ! find end of the option text IF y2%=0 THEN y2%=LEN(x$) ENDIF value$=MID$(x$,y%,y2%-y%+1) x$=TRIM$(TRIM$(LEFT$(x$,x%-1))+" "+TRIM$(RIGHT$(x$,LEN(x$)-y2%))) ELSE x$=" "+x$+" " x$=LEFT$(x$,x%)+RIGHT$(x$,LEN(x$)-x%-LEN(opt$)) ENDIF ENDIF ENDIF x$=TRIM$(x$) strip_inverted_commas(value$) RETURN > PROCEDURE strip_inverted_commas(VAR text$) ' ' If a string is enclosed within inverted commas, then they are stripped ' from the string - used on text passed to EdWord through the command line. ' e.g. the string "DH0:Direct/File" will be converted to DH0:Direct/File. ' text$=TRIM$(text$) IF LEFT$(text$,1)=CHR$(34) THEN text$=RIGHT$(text$,LEN(text$)-1) ENDIF IF RIGHT$(text$,1)=CHR$(34) THEN text$=LEFT$(text$,LEN(text$)-1) ENDIF RETURN > PROCEDURE dosprint(text$) ' ' Writes a line of text out to the default CLI window (if one exists). ' Used to display the command line option if the `?' command line is used ' IF Output()<>0 THEN text$=text$+CHR$(10) ~Write(Output(),V:text$,LEN(text$)) ENDIF RETURN > PROCEDURE infoprint(text$) ' ' Writes a line of text out to the default CLI window (if one exists). ' Used to display the command line option if the `?' command line is used ' Same as DOSPrint(), but will allow CTRL+C breaks. ' IF (NOT ctrl_c!) THEN detect_ctrlc IF ctrl_c! THEN dosprint("***Break") ENDIF ENDIF ' IF (NOT ctrl_c!) THEN dosprint(text$) ENDIF RETURN > PROCEDURE detect_ctrlc ' ' Detects whether CTRL+C was hit by the user by using the SetSignal() ' library call with the SIGBREAK_CTRL_C ($1000) define ' signals%=SetSignal(0,0) sigbreakc%=&H1000 IF (signals% AND sigbreakc%)<>0 THEN ~SetSignal(0,sigbreakc%) ctrl_c!=TRUE ELSE ctrl_c!=FALSE ENDIF RETURN ' ******************************* FONTS STUFF ******************************* > PROCEDURE set_topaz(size%) ' ' Sets the internal topaz font point size ' Where SIZE = 8 or 9 ' LOCAL font$ IF topazptr%<>0 THEN ! Close any previous topaz font ~CloseFont(topazptr%) ENDIF ' font$="topaz.font"+CHR$(0) attr%(0)=VARPTR(font$) attr%(1)=size%*65536 topazptr%=OpenFont(VARPTR(attr%(0))) IF topazptr%<>0 THEN ~SetFont({winptr%(currwindow%)+50},topazptr%) ENDIF RETURN > PROCEDURE style(n%) ' ' style = 0 for normal ' 1 for underline ' 2 for bold ' 4 for italics ' IF winptr%(currwindow%)<>0 THEN n%=n% MOD 16 ~SetSoftStyle({winptr%(currwindow%)+50},n%,&X1111) ENDIF RETURN > PROCEDURE load_font ' ' Loads the font with the name DEFFONT$ into memory and returns a pointer ' to its structure in the DEFFONT variable. Only 8x8 fixed-width fonts are ' allowed and any other sizes or formats will be ignored and the default ' topaz font will be used. ' LOCAL l$,t$,font$,use_topaz$ ' use_topaz$="USE TOPAZ 80" ! used for error requesters ' IF deffont$<>"topaz" THEN l$="diskfont.library"+CHR$(0) diskfontlib%=OpenLibrary(V:l$,0) ' IF diskfontlib% THEN font$=deffont$+".font"+CHR$(0) t$=MKL$(V:font$)+MKI$(8)+MKI$(0) deffont%=OpenDiskFont(V:t$) ! Load a DISK-Font font_xsize%=DPEEK(deffont%+24) ' IF NOT BTST(PEEK(deffont%+23),5) THEN ! Check font not proportional IF font_xsize%=8 THEN ! Check font width = 8 IF DPEEK(deffont%+20)<>8 THEN ! Check that point size = 8 ~CloseFont(deffont%) deffont%=0 ENDIF IF deffont%=0 request("Cannot Find 8-point Font|"+CHR$(34)+deffont$+".font"+CHR$(34),use_topaz$,"",x%) ENDIF ELSE ~CloseFont(deffont%) deffont%=0 request("Font Has A Width Of "+STR$(font_xsize%)+" Pixels|Only 8x8 Fonts Are Supported",use_topaz$,"",x%) ENDIF ELSE ~CloseFont(deffont%) deffont%=0 request("Specified Font Is Proportional|Only Fixed-Width Fonts Are Allowed",use_topaz$,"",x%) ENDIF ELSE request("Cannot Open The diskfont.library !",use_topaz$,"",x%) ENDIF ENDIF ' IF deffont%=0 THEN deffont$="topaz" font$=deffont$+".font"+CHR$(0) t$=MKL$(V:font$)+MKI$(8)+MKI$(0) deffont%=OpenFont(V:t$) ! Load ROM-Font - Topaz 80 ENDIF RETURN > PROCEDURE close_font IF deffont%<>0 ! Close the default font ~CloseFont(deffont%) ENDIF ' IF topazptr%<>0 THEN ! Close any topaz fonts used ~CloseFont(topazptr%) ENDIF ' IF diskfontlib%<>0 ! Close diskfont.library ~CloseLibrary(diskfontlib%) ENDIF RETURN > PROCEDURE set_font(win%) LOCAL rp% ' IF windowerror! THEN win%=0 ENDIF ' IF winptr%(win%)<>0 THEN rp%={winptr%(win%)+50} IF rp%<>0 AND deffont%<>0 AND winptr%(win%)<>0 ~SetFont(rp%,deffont%) ~SetSoftStyle(rp%,0,AskSoftStyle(rp%)) ENDIF ENDIF RETURN ' ************************* UTILITY SUBROUTINES ***************************** > PROCEDURE strip_chars ' ' This facility lets the user strip any range of character ' codes from the file. This can be used, for example, to ' strip all non-ascii characters from a file. To this end, ' there is a gadget which will specify the character range ' of non-ascii characters for the stripping operation. ' I do this by creating a 256 byte table (held in a string) ' which contains a zero or a one for every single ascii ' code stating whether it is to be stripped or not. ' LOCAL l%,char%,x%,strip$ ' DIM range1%(20),range2%(20) ' ' Was facility called by an ARexx command? ' IF arexx_command! THEN okay!=TRUE strip$=TRIM$(argv$(1)) IF (strip$="" OR INSTR(strip$,",,")<>0) THEN strip$="0-8,11-31,127-255" ENDIF ELSE open_window(2,130,50,390,65,"Strip Character Codes") IF NOT unable_to_open_window! THEN ' colour2(2,pen1%,backcol%) text(2,32,28,"Character Range :") create_gadget(2,20,40,"STRIP",gad1%()) create_gadget(2,150,40,"@NON-ASCII",gad3%()) create_gadget(2,302,40,cancel$,gad2%()) REPEAT string_gadget(2,183,28,20,80,strip$,dummy%) strip$=TRIM$(strip$) test_gadget(2,gad1%(),okay!) test_gadget(2,gad2%(),cancel!) test_gadget(2,gad3%(),hit!) IF hit! THEN strip$="0-8,11-31,127-255" string_position%=100 ENDIF ' IF dummy%=2 THEN okay!=TRUE ENDIF IF okay! AND (strip$="" OR INSTR(strip$,",,")<>0) THEN okay!=FALSE cancel!=TRUE ENDIF UNTIL okay! OR cancel! OR abortgadget! test_gadget_keypress(2,gad1%(),okay!) test_gadget_keypress(2,gad2%(),cancel!) close_window(2) ENDIF ENDIF ' IF okay! THEN ' ' Calculate the ranges which are specified by the ' the text string. ' message("Stripping Characters ...") cursor_off set_pointer(1) clare%=0 DO EXIT IF strip$="" x%=INSTR(strip$,",") IF x%<>0 THEN range$=LEFT$(strip$,x%-1) strip$=RIGHT$(strip$,LEN(strip$)-x%) ELSE range$=strip$ strip$="" ENDIF ' x%=INSTR(range$,"-") IF x%<>0 THEN range1%(clare%)=ABS(VAL(LEFT$(range$,x%-1))) range2%(clare%)=ABS(VAL(RIGHT$(range$,LEN(range$)-x%))) ELSE range1%(clare%)=ABS(VAL(range$)) range2%(clare%)=range1%(clare%) ENDIF clare%=clare%+1 LOOP ' ' Make up a boolean table of 256 bytes stating whether or ' not any ASCII character is to stripped or left in the document ' (0=not strip, 1=strip) ' strip$="" FOR char%=0 TO 255 a!=FALSE FOR l%=0 TO clare%-1 IF char%>=range1%(l%) AND char% PROCEDURE change_time ' ' lets the user modify the current system time. ' LOCAL dummy%,newtime$ ' open_window(2,130,50,350,65,"Set Current Time") IF NOT unable_to_open_window! THEN ' newtime$=TIME$ colour2(2,pen1%,backcol%) text(2,30,28," Please Enter New Time :") create_gadget(2,20,40,accept$,gad1%()) create_gadget(2,262,40,cancel$,gad2%()) REPEAT string_gadget(2,238,28,9,8,newtime$,dummy%) test_gadget(2,gad1%(),okay!) test_gadget(2,gad2%(),cancel!) ' IF dummy%=2 THEN okay!=TRUE ENDIF UNTIL okay! OR cancel! OR abortgadget! test_gadget_keypress(2,gad1%(),okay!) close_window(2) ' IF okay! THEN SETTIME newtime$,DATE$ ENDIF ENDIF ' RETURN > PROCEDURE insert_ascii ' ' Prints an ASCII table of characters and gives the user the ' ability to enter any such character into the current document. ' The display depends upon the screen resolution (due to size probs) :- ' ' NTSC 640x200 - displays chars 35-255 ' ALL OTHERS - displays chars 9-255 ' ' LOCAL st%,lines%,okay!,cancel!,asciiy%,botline%,newnumb%,mx%,my% ' ' Check to see if this was called from an ARexx command ... ' IF arexx_command! THEN code$=argv$(1) code%=ABS(INT(VAL(code$))) IF code%<0 OR code%>255 THEN arexx_result("InsertAscii <0..255> only",10) okay!=FALSE ELSE okay!=TRUE ENDIF ELSE IF screenres%=200 THEN open_window(2,15,14,640,200,"Insert Ascii Character") asciiy%=185 botline%=170 st%=35 ELSE open_window(2,15,14,640,230,"Insert Ascii Character") asciiy%=210 botline%=188 st%=9 ENDIF ' IF NOT unable_to_open_window! THEN create_gadget(2,548,asciiy%-9,cancel$,gad2%()) create_gadget(2,24,asciiy%-9,"INSERT CHAR",gad1%()) colour2(2,pen1%,backcol%) text(2,205,asciiy%,"Enter Code (0-255) :") refresh_string(2,381,asciiy%,4,"") charspercol%=13 ' restore_ascii_screen(asciigrabed!) IF NOT asciigrabed! THEN ' GRAPHMODE 0 FOR lines%=0 TO 18 a$="" b$="" FOR colum%=0 TO charspercol%-1 curcode%=st%+lines%*charspercol%+colum% IF curcode%<256 THEN IF hexascii! THEN a$=a$+"$"+RIGHT$("0"+HEX$(curcode%),2)+" " ELSE a$=a$+RIGHT$("00"+STR$(curcode%),3)+" " ENDIF b$=b$+CHR$(curcode%)+" " ENDIF NEXT colum% colour2(2,pen2%,backcol%) text(2,15,lines%*9+24,a$) colour2(2,pen1%,backcol%) text(2,40,lines%*9+24,b$) NEXT lines% GRAPHMODE 1 ' @save_ascii_screen ' ENDIF ' code$="" code%=-1 REPEAT string_gadget(2,381,asciiy%,4,3,code$,exit%) ' ' Check for a mouse click over any character or its code ' IF mouse! AND event_y%>14 AND event_y%"") AND (code%<=255) THEN okay!=TRUE ELSE cancel!=TRUE ENDIF ENDIF UNTIL okay! OR cancel! OR abortgadget! test_gadget_keypress(2,gad1%(),okay!) test_gadget_keypress(2,gad2%(),cancel!) ' close_window(2) ENDIF ENDIF ' IF okay! AND TRIM$(code$)<>"" THEN IF code%=lf% THEN line_feed ELSE insert_char(CHR$(code%)) ENDIF ENDIF RETURN > PROCEDURE define_fkeys ' ' Prints 10 sting gadgets to allow the user the ability to define ' any of the F-Keys (F1,F2...F10) so that it will print any piece ' of text when it is pressed. (sort of macro definition) ' LOCAL diff%,marg%,a$,pos%,exit!,laura% ' open_window(2,120,20,390,200,"Define Function Keys") IF NOT unable_to_open_window! THEN diff%=15 marg%=70 FOR l%=1 TO 10 colour2(2,pen1%,backcol%) a$="F"+STR$(l%)+" :" IF l%<10 THEN a$=" "+a$ ENDIF text(2,15,l%*diff%+10,a$) refresh_string(2,marg%,l%*diff%+10,37,fkey$(l%-1)) NEXT l% create_gadget(2,172,175,accept$,gad1%()) pos%=0 REPEAT FOR laura%=0 TO 9 abc$=fkey$(laura%) string_group(2,marg%,(laura%+1)*diff%+10,37,60,laura%,pos%,abc$,way%) fkey$(laura%)=abc$ NEXT laura% pos%=(pos%+SGN(way%)+10) MOD 10 test_gadget(2,gad1%(),exit!) ' IF way%=2 THEN exit!=TRUE ENDIF UNTIL exit! OR abortgadget! test_gadget_keypress(2,gad1%(),exit!) ' close_window(2) ENDIF RETURN > PROCEDURE system_status ' ' displays some statistical information about the current state of the ' system. This includes free Chip/Fast/Total memory; Disk Label; Number ' of block on disk; Number of blocks used; State of protection tab ' open_window(2,120,20,350,200,"System Status") IF NOT unable_to_open_window! THEN draw_box(2,30,22,320,72) draw_box(2,30,84,320,171) colour2(2,pen2%,backcol%) int2string(AvailMem(2)) text(2,170,41,aimee$+" ("+STR$(AvailMem(2) DIV 1024)+"K)") int2string(AvailMem(4)) text(2,170,51,aimee$+" ("+STR$(AvailMem(4) DIV 1024)+"K)") int2string(AvailMem(&H20000)) text(2,170,61,aimee$+" ("+STR$(AvailMem(&H20000) DIV 1024)+"K)") colour2(2,pen1%,backcol%) heading(2,350,24,"Available Memory") text(2,42,41," Chip Memory :") text(2,42,51," Fast Memory :") text(2,42,61,"Largest Block :") heading(2,350,87,"Disk Drive") text(2,40,101," Unit Name :") text(2,40,111," Disk Label :") text(2,40,121,"Total Blocks :") text(2,40,131," Blocks Free :") text(2,40,141," Protection :") create_gadget(2,52,151,"DF0:",df0%()) create_gadget(2,117,151,"DF1:",df1%()) create_gadget(2,182,151,"DF2:",df2%()) create_gadget(2,247,151,"DH0:",dh0%()) create_gadget(2,150,178,"~"+confirm$,gad1%()) ' assign(device$) ! get the list of devices device$=UPPER$(device$) IF INSTR(device$,"DF1:")=0 THEN gadget_off(2,df1%()) ENDIF IF INSTR(device$,"DF2:")=0 THEN gadget_off(2,df2%()) ENDIF IF INSTR(device$,"DH0:")=0 THEN gadget_off(2,dh0%()) ENDIF ' display_drive_info("df0:") REPEAT test_for_sleep(2) test_gadget(2,df0%(),test!) IF test!=TRUE THEN display_drive_info("df0:") ENDIF test_gadget(2,df1%(),test!) IF test!=TRUE THEN display_drive_info("df1:") ENDIF test_gadget(2,df2%(),test!) IF test!=TRUE THEN display_drive_info("df2:") ENDIF test_gadget(2,dh0%(),test!) IF test!=TRUE THEN display_drive_info("dh0:") ENDIF test_gadget(2,gad1%(),exit!) ' IF event_key$=CHR$(13) OR event_key$=CHR$(27) OR UPPER$(event_key$)="O" THEN exit!=TRUE ENDIF UNTIL exit! OR abortgadget! test_gadget_keypress(2,gad1%(),exit!) close_window(2) ENDIF RETURN > PROCEDURE jump_to_line ' ' Ask the user for a line and, if it is valid, then it repositions the ' cursor over that line ' IF arexx_command! THEN lineno%=MIN(VAL(argv$(1)),nooflines%) ELSE lineno%=-1 get_line_number("Jump To Line Number",320,"Enter A Line Number (1.."+STR$(nooflines%)+") :",lineno%) ENDIF set_pointer(1) goto_line(lineno%,TRUE,TRUE) set_pointer(0) update_line update_column cursor_on RETURN > PROCEDURE about ' ' Where I get my name mentioned with a few little editor details ' LOCAL full%,x$,info$ ' open_window(2,130,50,380,190,"About EdWord Professional") IF NOT unable_to_open_window! THEN ' arexx_command!=FALSE set_topaz(9) style(2) t1$="EdWord Pro Text Editor" t2$="~~~~~~~~~~~~~~~~~~~~~~" IF screencolours%>2 THEN graphmode(2,0) colour2(2,pen1%,backcol%) text(2,82,25,t1$) text(2,82,34,t2$) ENDIF colour2(2,pen2%,backcol%) text(2,80,24,t1$) text(2,80,33,t2$) graphmode(2,1) set_font(2) colour1(2,pen1%) info$=CHR$(34)+"The Language Editor"+CHR$(34)+" - Version "+version$ centre_text(2,info$,380,46) centre_text(2,"Written "+author$+", 12.6.93",380,55) centre_text(2,CHR$(169)+" 1993 "+author$,380,64) text(2,30,80," ARexx Port :") text(2,30,90,"Public Scrn :") text(2,30,100,"System Date :") text(2,30,110,"Current Dir :") text(2,30,120," Disk Space :") text(2,30,130," File Size :") text(2,30,140,"Text Status :") text(2,30,150,"Free Buffer :") colour1(2,pen2%) ' bytes%=bytesfree%(0) full%=(noofchars%*100) DIV (memorysize%-memlow%) filek%=(noofchars%+false_eof!) DIV 1024 diskk%=(bytes%) DIV 1024 ' x$=path$(0) IF x$="" THEN x$=defaultdir$ ENDIF IF LEN(x$)>28 THEN filepath$=".."+RIGHT$(x$,26) ELSE filepath$=x$ ENDIF ' text(2,140,80,arexx_port_name$) text(2,140,100,DATE$) text(2,140,110,filepath$) ' IF NOT workbench_2.0! THEN text(2,140,90,"Not Available") ELSE pubname$=SPACE$(100) IF use_wbench! THEN reg%(8)=V:pubname$ reg%(14)=_IntBase RCALL _IntBase-&H246,reg%() ELSE BMOVE pubscreenname%,V:pubname$,20 ENDIF temp$="" FOR loop%=1 TO 20 EXIT IF loop%>LEN(pubname$) EXIT IF MID$(pubname$,loop%,1)=CHR$(0) temp$=temp$+MID$(pubname$,loop%,1) NEXT loop% text(2,140,90,temp$) ENDIF ' int2string(bytes%) text(2,140,120,aimee$+" bytes ("+STR$(diskk%)+"K)") ' int2string(noofchars%+false_eof!) IF noofchars%+false_eof!=1 THEN text(2,140,130,aimee$+" byte ("+STR$(filek%)+"K)") ELSE text(2,140,130,aimee$+" bytes ("+STR$(filek%)+"K)") ENDIF ' IF docupdated! OR lineupdated! THEN text(2,140,140,"Document Updated") ELSE text(2,140,140,"No Changes Made") ENDIF ' int2string(memorysize%-noofchars%-memlow%) text(2,140,150,aimee$+" bytes ("+STR$(full%)+"% full)") create_gadget(2,155,162,"~BORING!",gad1%()) REPEAT test_for_sleep(2) test_gadget(2,gad1%(),okay!) ' IF event_key$=CHR$(13) OR event_key$=CHR$(27) OR UPPER$(event_key$)="B" THEN okay!=TRUE ENDIF UNTIL okay! OR abortgadget! test_gadget_keypress(2,gad1%(),okay!) close_window(2) ENDIF ' RETURN > PROCEDURE find ' ' Find a specified string from the current cursor position ' the search can be made case dependant/independant and search ' both forwards and backwards ' LOCAL code%,textfound! ' ' Check to see if this operation was called from an ARexx command ' IF arexx_command! THEN find$=argv$(3) code%=1 ELSE find_window("Find Text",TRUE,code%) ENDIF ' IF code%<>0 THEN search_text(0,textfound!,x%) IF NOT textfound! THEN alert("String Not Found!") ENDIF ENDIF RETURN > PROCEDURE find_next LOCAL textfound!,x% ' IF find$<>"" THEN search_text(0,textfound!,x%) IF NOT textfound! THEN alert("String Not Found!") ENDIF ENDIF RETURN > PROCEDURE find_previous ' ' Finds the previous occurrence of a text string ' forward!=NOT forward! find_next forward!=NOT forward! RETURN > PROCEDURE find_replace ' ' Same as the find option but also provides the facility to replace ' the text found with another string ' LOCAL counter% ' ' Check to see if this function has been called by an ARexx command ... ' IF arexx_command! THEN find$=argv$(1) find_replace$=argv$(2) code%=1 ELSE find_replace_window(code%) ENDIF ' IF code%<>0 THEN exit!=FALSE counter%=0 REPEAT search_text(counter%,found!,pos%) IF found! THEN find_replace_options(option%) SELECT option% CASE 0 exit!=TRUE CASE 1 replace(pos%,find$,find_replace$) counter%=LEN(find_replace$)-1 ' IF fullrefresh! THEN refresh_page_nocursor ELSE refresh_curr_line ENDIF ' IF error! THEN found!=FALSE ENDIF CASE 2 replace_all found!=FALSE CASE 3 counter%=0 ' Skip option - so do nothing (I'm good at programming that!) ENDSELECT ELSE alert("String Not Found!") ENDIF UNTIL (NOT found!) OR (exit!) update_column cursor_on ENDIF RETURN > PROCEDURE find_hex ' ' Search through the file for a specified byte arrangement as opposed ' to string arrangement - i.e. search for numbers as opposed to characters ' IF arexx_command! THEN findhex$=argv$(1) code%=1 ELSE find_hex_window(code%) ENDIF ' IF code%<>0 THEN create_hex_string(findhex$,hex$) temp$=find$ find$=hex$ temp!=casedep! casedep!=TRUE search_text(0,dummy!,x%) IF NOT dummy! THEN alert("Hex String Not Found!") ENDIF casedep!=temp! find$=temp$ ENDIF RETURN > PROCEDURE goto_offset ' ' Moves the cursor position to a certain byte offset within ' the current file (where byte 1 = the first byte in the file) ' ' Check to see if this was called by an ARexx command ... ' IF arexx_command! THEN newoffset%=MIN(VAL(argv$(1)),noofchars%) ELSE newoffset%=curradd%-docstart%+1 get_line_number("Goto Byte Offset",340,"Enter A New Byte Offset (1.."+STR$(noofchars%)+") :",newoffset%) newoffset%=MIN(newoffset%,noofchars%) ENDIF ' IF (newoffset%>0) AND (newoffset%<>curradd%-docstart%+1) THEN message("Repositioning ...") set_pointer(1) cursor_off newoffset%=docstart%+newoffset%-1 line%=1 FOR l%=docstart%+1 TO newoffset% IF PEEK(l%-1)=lf% THEN line%=line%+1 ENDIF NEXT l% ' oldindent%=indent% goto_line(line%,TRUE,FALSE) curradd%=newoffset% indent%=oldindent% get_cursorx IF refresh! OR newpage! THEN refresh_page ENDIF ' cursor_on update_prop update_line update_column make_undo_string set_pointer(0) message("") ENDIF RETURN > PROCEDURE occurence_count ' ' Counts the number of times that a string occurs in the document ' LOCAL temp$,a$,occ%,cent% ' temp$=find$ find_window("Occurrence Count",FALSE,code%) IF code%<>0 THEN open_window(2,145,50,350,101,"Occurrence Count") IF NOT unable_to_open_window! THEN draw_box(2,20,17,327,32) draw_box(2,20,38,327,68) a$=" "+CHR$(34)+TRIM$(LEFT$(find$,28))+CHR$(34) cent%=(350-LEN(a$)*8) DIV 2 colour2(2,pen2%,backcol%) text(2,cent%,27,a$) text(2,183,60,"none") IF casedep! THEN text(2,183,50,"ON") ELSE text(2,183,50,"OFF") ENDIF ' colour2(2,pen1%,backcol%) text(2,cent%,27,"Text =") text(2,30,50," Case Dependancy =") text(2,30,60,"Occurences Found =") colour1(2,pen2%) ' occ%=0 address%=docstart%-1 find_occurence(found!,address%) WHILE found! occ%=occ%+1 find_occurence(found!,address%) text(2,183,60,STR$(occ%)+" ") WEND ' create_gadget(2,160,77,"~"+confirm$,gad1%()) REPEAT test_for_sleep(2) test_gadget(2,gad1%(),okay!) IF event_key$=CHR$(13) OR event_key$=CHR$(27) OR UPPER$(event_key$)="O" THEN okay!=TRUE ENDIF UNTIL okay! OR abortgadget! test_gadget_keypress(2,gad1%(),okay!) close_window(2) ENDIF ENDIF find$=temp$ RETURN > PROCEDURE repeat_text ' ' Lets the user insert a string into the document composed of number of ' copies of the same piece of text. The user can specify the string and ' the number of times to repeat the string. ' LOCAL okay!,cancel!,rep$,casepos%,move% open_window(2,180,40,260,76,"Repeat Text") IF NOT unable_to_open_window! THEN colour2(2,pen1%,backcol%) text(2,15,24," Text String :") text(2,15,38,"Repeat Count :") create_gadget(2,19,50,accept$,gad1%()) create_gadget(2,170,50,cancel$,gad2%()) refresh_number(2,140,38,4,repeatcount%) casepos%=0 REPEAT string_group(2,140,24,11,10,0,casepos%,repeattext$,move%) number_group(2,140,38,4,2,1,casepos%,repeatcount%,move%) refresh_number(2,140,38,4,repeatcount%) casepos%=(casepos%+2+move%) MOD 2 ' test_gadget(2,gad1%(),okay!) test_gadget(2,gad2%(),cancel!) ' IF move%=2 THEN IF repeattext$<>"" AND repeatcount%<>0 THEN okay!=TRUE ELSE cancel!=TRUE ENDIF ENDIF UNTIL okay! OR cancel! OR abortgadget! test_gadget_keypress(2,gad1%(),okay!) test_gadget_keypress(2,gad2%(),cancel!) close_window(2) ' IF okay! THEN fkey$(10)="" FOR l%=1 TO repeatcount% fkey$(10)=fkey$(10)+repeattext$ NEXT l% insert_fkey("F10") ENDIF ENDIF RETURN > PROCEDURE new_screen_mode ' ' Changes the current screen resolution. Currently supported modes, ' in either 2 or 4 colours, are :- ' ' PAL Custom screen - 640x256 pixels ' PAL Workbench screen - 640x256 pixels ' PAL Interlace screen - 640x512 pixels ' NTSC Custom screen - 640x200 pixels ' NTSC Workbench screen - 640x200 pixels ' NTSC Interlace screen - 640x400 pixels ' LOCAL first_time!,mode_pal!,mode_interlace!,initres%,maxres% DIM mo1%(3),mo2%(3),mo3%(3),mo4%(4) ' newcol%=screencolours% new_wbench!=use_wbench! newres%=bottomline%+24 initres%=newres% ' IF arexx_command! THEN IF use_wbench! THEN maxres%=wbench_size% ELSE maxres%=DPEEK(scrptr%(1)+14) ENDIF newres%=MIN(MAX(ABS(VAL(argv$(2))),100),maxres%) window_ycoord%=MIN(ABS(VAL(argv$(1))),maxres%-newres%) initres%=-1 okay!=TRUE ELSE open_window(2,120,32,275,153,"Screen Resolution") IF NOT unable_to_open_window! THEN ' create_gadget(2,27,123,accept$,gad1%()) create_gadget(2,179,123,cancel$,gad2%()) ' mode_pal!=(wbench_size%>240 AND wbench_size%<300) OR (wbench_size%>500) mode_interlace!=(newres%>399) first_time!=TRUE ' mo1!=FALSE mo2!=FALSE mo3!=FALSE mo4!=FALSE ' colour2(2,pen1%,backcol%) text(2,50,105,"Screen Height =") REPEAT ' ' Act upon a gadget selection and modify the specific boolean/integer ' IF mo1! THEN new_wbench!=NOT new_wbench! ELSE IF mo2! AND (NOT ntscamiga!) mode_pal!=NOT mode_pal! ELSE IF mo3! mode_interlace!=NOT mode_interlace! ELSE IF mo4! newcol%=(((newcol%/2) MOD 2)+1)*2 ENDIF ' ' If we are in WorkBench, then we cannot be in Interlace ' (the two are mutually exclusive) ' IF new_wbench! AND mo1! THEN IF wbench_interlace! THEN mode_interlace!=TRUE ELSE mode_interlace!=FALSE ENDIF mo3!=mo1! ENDIF IF mo3! AND new_wbench! THEN IF wbench_interlace!<>mode_interlace! THEN new_wbench!=NOT new_wbench! mo1!=mo3! ENDIF ENDIF ' ' Refresh the gadgets ' IF mo1! OR first_time! THEN IF new_wbench! THEN create_swirl_gadget(2,35,23,"SCREEN = WORKBENCH ",mo1%()) ELSE create_swirl_gadget(2,35,23,"SCREEN = CUSTOM ",mo1%()) ENDIF ENDIF ' IF mo2! OR first_time! THEN IF mode_pal! THEN create_swirl_gadget(2,35,41,"STANDARD = PAL ",mo2%()) ELSE create_swirl_gadget(2,35,41,"STANDARD = NTSC ",mo2%()) ENDIF ENDIF ' IF mo3! OR first_time! THEN IF mode_interlace! THEN create_swirl_gadget(2,35,59,"INTERLACE = ON ",mo3%()) ELSE create_swirl_gadget(2,35,59,"INTERLACE = OFF ",mo3%()) ENDIF ENDIF ' IF mo4! OR first_time! THEN create_swirl_gadget(2,35,77,"COLOURS = "+STR$(newcol%)+" ",mo4%()) ENDIF first_time!=FALSE ' ' Check the maximum screen height the new resolution allows ' maxres%=200 IF mode_pal! THEN maxres%=256 ENDIF IF mode_interlace! THEN maxres%=maxres%*2 ENDIF IF new_wbench! THEN maxres%=wbench_size% ENDIF ' IF mo1! OR mo2! OR mo3! OR mo4! THEN newres%=maxres% ELSE newres%=MAX(MIN(newres%,maxres%),100) ENDIF ' number_gadget(2,185,105,4,3,newres%,move%) ' test_gadget(2,mo1%(),mo1!) test_gadget(2,mo2%(),mo2!) test_gadget(2,mo3%(),mo3!) test_gadget(2,mo4%(),mo4!) test_gadget(2,gad1%(),okay!) test_gadget(2,gad2%(),cancel!) ' IF move%=2 THEN okay!=TRUE ELSE IF move%=1 newres%=MAX(newres%-8,100) ELSE IF move%=-1 newres%=MIN(newres%+8,maxres%) ENDIF UNTIL cancel! OR okay! OR abortgadget! test_gadget_keypress(2,gad1%(),okay!) test_gadget_keypress(2,gad2%(),cancel!) close_window(2) ENDIF ENDIF ' ' Update the resolution if a new mode/height has been selected ' IF okay! AND (initres%<>newres% OR use_wbench!<>new_wbench! OR screencolours%<>newcol%) THEN IF newres%<>maxres% THEN custom_size%=newres% newres%=maxres% custom_size!=TRUE ENDIF change_resolution(TRUE) ENDIF ' ERASE mo1%(),mo2%(),mo3%(),mo4%() RETURN > PROCEDURE stats ' ' Displays the number of lines,words and bytes in the main document and ' the current clipboard (if any) ' open_window(2,150,40,306,195,"Word Count") IF NOT unable_to_open_window! THEN draw_box(2,30,23,276,88) draw_box(2,30,103,276,160) colour2(2,pen1%,backcol%) clare$="Calculating ... Please Wait" heading(2,306,26,"Main Document") text(2,50,40,"Number of Lines :") text(2,50,50,"Number of Words :") text(2,50,60,"Number of Bytes :") text(2,50,70,"Max Line Length :") text(2,50,80,"Largest Line No :") heading(2,306,106,"Clipboard") text(2,50,120,"Number of Lines :") text(2,50,130,"Number of Words :") text(2,50,140,"Number of Bytes :") text(2,38,178,clare$) IF NOT blockcopied! THEN a$="Block Type = None" ELSE IF verticalclip! a$="Block Type = Vertical" ELSE a$="Block Type = Horizontal" ENDIF centre_text(2,a$,306,153) colour1(2,pen2%) display_integer(2,195,40,nooflines%) display_integer(2,195,60,noofchars%+false_eof!) count_lines(clipstart%,clipsize%,cliplines%) display_integer(2,195,120,cliplines%) display_integer(2,195,140,clipsize%) wordcount(docstart%,noofchars%,docwords%) display_integer(2,195,50,docwords%) display_integer(2,195,70,reg%(4)-1) display_integer(2,195,80,MAX(reg%(10),1)) ' wordcount(clipstart%,clipsize%,clipwords%) display_integer(2,195,130,clipwords%) ! No. of words in clipboard colour1(2,backcol%) text(2,38,178,clare$) create_gadget(2,128,170,"~"+confirm$,gad1%()) ' REPEAT test_for_sleep(2) test_gadget(2,gad1%(),exit!) ' IF event_key$=CHR$(13) OR event_key$=CHR$(27) OR UPPER$(event_key$)="O" THEN exit!=TRUE ENDIF UNTIL exit! OR abortgadget! test_gadget_keypress(2,gad1%(),exit!) close_window(2) ENDIF RETURN > PROCEDURE set_tab_size ' ' Allows the user to change the current tab size ' DIM gadup%(3),gaddn%(3) ' ' Check to see if this function was called from an ARexx command ... ' IF arexx_command! THEN tabsize%=MAX(MIN(VAL(argv$(1)),20),1) cancel!=FALSE ELSE ' open_window(2,170,60,300,70,"Tab Size") IF NOT unable_to_open_window! THEN create_gadget(2,20,45,accept$,gad1%()) create_gadget(2,119,45,"@ ",gadup%()) create_gadget(2,150,45,"@ ",gaddn%()) create_gadget(2,212,45,cancel$,gad2%()) colour2(2,pen1%,backcol%) text(2,50,30,"Current Tab Size = ") ' sh1%=shadow1% sh2%=shadow2% shadow1%=backcol% shadow2%=backcol% up_scroll_arrow(2,129,47) dn_scroll_arrow(2,160,47) shadow1%=sh1% shadow2%=sh2% ' oldtab%=tabsize% REPEAT number_gadget(2,212,30,3,2,tabsize%,exit%) test_gadget(2,gad1%(),okay!) test_gadget(2,gad2%(),cancel!) test_gadget(2,gadup%(),up!) test_gadget(2,gaddn%(),down!) IF (up! OR exit%=-1) AND tabsize%<20 THEN tabsize%=tabsize%+1 refresh_page_nocursor ELSE IF (down! OR exit%=1) AND tabsize%>1 tabsize%=tabsize%-1 refresh_page_nocursor ENDIF tabsize%=MAX(MIN(tabsize%,20),1) ' IF exit%=2 THEN okay!=TRUE ENDIF UNTIL okay! OR cancel! OR abortgadget! test_gadget_keypress(2,gad1%(),okay!) close_window(2) ENDIF ENDIF ' IF NOT okay! THEN IF tabsize%<>oldtab% THEN tabsize%=oldtab% refresh_page ENDIF ELSE get_cursorx refresh_page update_tab ENDIF ' ERASE gadup%(),gaddn%() RETURN > PROCEDURE convert_tab2space ' ' This procedure will convert all occurences of a tab character (CHR$(9)) ' in the entire document into the corresponding number of spaces. A ' requester is displayed first so that the user can confirm this operation. ' LOCAL before$,after$,tempadd%,templine% ' request("TAB --> SPACE|~~~~~~~~~~~~~|Please Confirm Conversion Of|All Tab Characters To Spaces|(Using A Tab Size Of "+STR$(tabsize%)+")","TAB --> SPACE",cancel$,x%) IF x%<>0 THEN free_abyss message("Converting All Tabs Into Spaces ...") set_pointer(1) cursor_off ' dofast!=TRUE test%=AllocMem(memorysize%,1) IF test%<>0 THEN ~FreeMem(test%,memorysize%) ELSE dofast!=FALSE ENDIF ' IF dofast! THEN ' ' Use my mega-fast, optimised, machine code routine if there's enuf memory ' clear_registers reg%(8)=docstart% reg%(9)=V:noofchars% reg%(6)=memorysize% reg%(2)=tabsize% RCALL mc68000tabs2space%,reg%() error%=reg%(0) ' ELSE ' ' Otherwise, use the old slow, crap, GFA-BASIC routine ... ' tempadd%=docstart% templine%=1 error%=0 WHILE templine%<=nooflines% ' ' Get strings for the line before & after tab conversion ' convert_line(tempadd%,1,before$) convert_line(tempadd%,0,after$) ' ' Only change a line if the length of the string with tabs converted to ' spaces is different to the length of the string with just tab characters ' IF LEN(after$)<>LEN(before$) AND after$<>"" THEN replace(tempadd%,before$,after$) IF error! THEN error%=templine% templine%=nooflines% ENDIF ENDIF ' next_line(tempadd%) templine%=templine%+1 WEND ENDIF ' IF error%<>0 THEN inform("Could Not Convert Entire Document|Not Enough Free Buffer Memory!|Done Up To Line No. "+STR$(error%)) ENDIF ' docupdated!=TRUE set_pointer(0) message("") ignore_messages goto_top_of_file ENDIF RETURN > PROCEDURE erase_document ' ' Erase the current document from memory and reset all position ' variables ' IF (noofchars%=1) AND (NOT false_eof!) THEN request("Erase The Current Document!|Why Don't You Type Something|Worth Erasing First!","GOOD IDEA","",x%) ELSE request("Erase The Current Document !|All Will Be Lost - Are You Sure?","YES PLEASE","NO THANKS",x%) IF x%=1 THEN reset_position ENDIF ENDIF RETURN > PROCEDURE colours ' ' The colours preferences screen - for changing screen colours and ' settings for pen and background colours ' LOCAL okay!,cancel!,exit%,temppen1%,temppen2%,tempback%,tempshadow1%,tempshadow2%,test! DIM wbench%(3),def13%(3),def20%(3),p1%(3),p2%(3),p3%(3),p4%(3),m1%(3),m2%(3),m3%(3),m4%(3),temp%(3,2),wincols%(3,4,3) ' open_window(2,120,20,400,197,"Colours") IF NOT unable_to_open_window! THEN draw_box(2,40,20,360,80) draw_box(2,30,93,370,161) draw_box(2,250,30,311,55) colour1(2,pen1%) heading(2,400,23,"Palette") text(2,55,38," Red :") text(2,55,53,"Green :") text(2,55,68," Blue :") text(2,225,70,"Colour = 1 of "+STR$(screencolours%)) heading(2,400,96,"Window Colours") text(2,78,111,"Pen 1 Colour :") text(2,78,122,"Pen 2 Colour :") text(2,78,133," Background :") text(2,78,144," Shadow 1 :") text(2,78,155," Shadow 2 :") FOR l%=0 TO 2 colour2(2,backcol%,backcol%) text(2,150,38+l%*15," ") text(2,150,37+l%*15," ") draw_box(2,150,30+l%*15,183,40+l%*15) NEXT l% create_gadget(2,122,29,"@+",p1%()) create_gadget(2,122,44,"@+",p2%()) create_gadget(2,122,59,"@+",p3%()) create_gadget(2,323,30,"@+",p4%()) create_gadget(2,189,29,"@-",m1%()) create_gadget(2,189,44,"@-",m2%()) create_gadget(2,189,59,"@-",m3%()) create_gadget(2,323,43,"@-",m4%()) ' create_gadget(2,25,171,"~"+accept$,okay%()) create_gadget(2,105,171,"V~1.3",def13%()) create_gadget(2,168,171,"~WBENCH",wbench%()) create_gadget(2,247,171,"V~2.0",def20%()) create_gadget(2,310,171,"~"+cancel$,cancel%()) update_colours(0) ' temppen1%=pen1col% temppen2%=pen2col% tempback%=backcol% tempshadow1%=shadow1% tempshadow2%=shadow2% display_colour_gadgets(temppen1%,temppen2%,tempback%,tempshadow1%,tempshadow2%,wincols%()) ' curcol%=0 FOR l1%=0 TO 3 FOR l2%=0 TO 2 temp%(l1%,l2%)=colour%(l1%,l2%) NEXT l2% NEXT l1% ' REPEAT test_for_sleep(2) event_key$=UPPER$(event_key$) test_gadget(2,p4%(),test!) IF test! AND curcol%0 THEN curcol%=curcol%-1 update_colours(curcol%) ENDIF test_gadget(2,okay%(),okay!) ! ***** OKAY ***** test_gadget(2,cancel%(),cancel!) ! ***** CANCEL ***** test_gadget(2,def13%(),test!) ! ***** V1.3 COLOURS ***** IF test! OR event_key$="1" THEN test!=TRUE test_gadget_keypress(2,def13%(),test!) standard_colours(1) ENDIF test_gadget(2,def20%(),test!) ! ***** V2.0 COLOURS ***** IF test! OR event_key$="2" THEN test!=TRUE test_gadget_keypress(2,def20%(),test!) standard_colours(2) ENDIF test_gadget(2,wbench%(),test!) ! ***** WBENCH COLOURS ***** IF test! OR event_key$="W" THEN test!=TRUE test_gadget_keypress(2,wbench%(),test!) get_workbench_colours ensure_embossed(tempshadow1%,tempshadow2%) set_colours update_colours(curcol%) display_colour_gadgets(temppen1%,temppen2%,tempback%,tempshadow1%,tempshadow2%,wincols%()) ENDIF test_plus_or_minus(0,1,p1%()) test_plus_or_minus(1,1,p2%()) test_plus_or_minus(2,1,p3%()) test_plus_or_minus(0,-1,m1%()) test_plus_or_minus(1,-1,m2%()) test_plus_or_minus(2,-1,m3%()) test_colour_gadgets(temppen1%,temppen2%,tempback%,tempshadow1%,tempshadow2%,wincols%()) ' IF event_key$=CHR$(13) OR event_key$="A" THEN okay!=TRUE ELSE IF event_key$=CHR$(27) OR event_key$="C" cancel!=TRUE ENDIF ' UNTIL exit%=2 OR okay! OR cancel! OR abortgadget! test_gadget_keypress(2,okay%(),okay!) test_gadget_keypress(2,cancel%(),cancel!) ' close_window(2) IF NOT okay! THEN FOR l1%=0 TO 3 FOR l2%=0 TO 2 colour%(l1%,l2%)=temp%(l1%,l2%) NEXT l2% NEXT l1% set_colours ELSE IF pen1col%<>temppen1% OR pen2col%<>temppen2% OR backcol%<>tempback% forget_ascii_screen ENDIF pen1col%=temppen1% pen2col%=temppen2% backcol%=tempback% shadow1%=tempshadow1% shadow2%=tempshadow2% init_prop ' ' Have the workbench colours been updated? ' FOR l1%=0 TO 3 FOR l2%=0 TO 2 IF colour%(l1%,l2%)<>temp%(l1%,l2%) THEN colours_changed!=TRUE ENDIF NEXT l2% NEXT l1% IF use_wbench! THEN wbench_colours_changed!=colours_changed! ENDIF ENDIF ENDIF updatepencolours ' ERASE wbench%(),def13%(),def20%(),p1%(),p2%(),p3%(),p4%(),m1%(),m2%(),m3%(),m4%(),temp%(),wincols%() RETURN > PROCEDURE preferences ' ' The preferences screen - for changing screen colours and various ' switches as well as the current document buffer size ' LOCAL okay!,cancel!,exit%,tabx%,taby%,winy% ' DIM load%(3),save%(3),on1%(3),on2%(3),on3%(3),on4%(3),on5%(3),on6%(3),on7%(3),on8%(3),on9%(3),on0%(3),on10%(3),on11%(3),on12%(3),on13%(3),on14%(3),on15%(3) ' newres%=screenres% newcol%=screencolours% new_wbench!=use_wbench! ' old_autoindent!=autoindent! old_searchzoom!=searchzoom! old_saveicon!=saveicon! old_shiftdel!=shiftdel_word! old_backups!=backups! old_strip_eol!=strip_eol! old_showlinefeeds!=showlinefeeds! old_tab2space!=tab2space! old_pp_detect!=pp_detect! old_flash_gordon!=flash_gordon! old_configdir$=configdir$ old_word_wrap!=word_wrap! old_eol_overflow!=eol_overflow! old_alternate_cursor!=alternate_cursor! old_use_underline!=use_underline! old_use_asl!=use_asl! old_alt_gadgets!=alt_gadgets! ' ' Check to see if an ARexx command has called this procedure ' to load a configuration file ... ' IF arexx_command! THEN get_prefs!=TRUE configdir$=argv$(3) ELSE winy%=198 open_window(2,120,20,400,winy%,"Preferences") IF NOT unable_to_open_window! THEN colour2(2,pen1%,backcol%) text(2,45,32,"Auto Indent :") text(2,45,46,"Search Zoom :") text(2,45,60," Strip EOL :") text(2,45,74," Show LF's :") text(2,45,88,"PP Decrunch :") text(2,45,102,"S+Del=Word :") text(2,37,116,"Block Cursor :") text(2,37,130,"Asl File Req :") text(2,217,32," Save Icon :") text(2,217,46," Word Wrap :") text(2,217,60," BackUps :") text(2,209,74,"Tab Spaces :") text(2,209,88,"Cursor Flash :") text(2,209,102," Stop At EOL :") text(2,201,116,"Colour Cursor :") text(2,201,130," Alt Gadgets :") text(2,37,winy%-46," Config Dir :") ' ' Draw the tab2space arrowhead ' tabx%=206 taby%=74 line(2,tabx%+47,taby%-3,tabx%+32,taby%-3) pbox(2,tabx%+40,taby%-6,tabx%+41,taby%) pbox(2,tabx%+42,taby%-5,tabx%+43,taby%-1) pbox(2,tabx%+44,taby%-4,tabx%+45,taby%-2) ' show_switch(2,autoindent!,156,23,on1%()) show_switch(2,searchzoom!,156,37,on2%()) show_switch(2,strip_eol!,156,51,on6%()) show_switch(2,showlinefeeds!,156,65,on7%()) show_switch(2,saveicon!,327,23,on3%()) show_switch(2,word_wrap!,327,37,on10%()) show_switch(2,backups!,327,51,on5%()) show_switch(2,tab2space!,327,65,on8%()) show_switch(2,pp_detect!,156,79,on9%()) show_switch(2,flash_gordon!,327,79,on0%()) show_switch(2,shiftdel_word!,156,93,on4%()) show_switch(2,NOT eol_overflow!,327,93,on11%()) show_switch(2,NOT use_underline!,156,107,on12%()) show_switch(2,alternate_cursor!,327,107,on13%()) show_switch(2,use_asl!,156,121,on14%()) show_switch(2,alt_gadgets!,327,121,on15%()) IF aslbase%=0 THEN gadget_off(2,on14%()) ENDIF ' create_gadget(2,31,winy%-30,accept$,okay%()) create_gadget(2,140,winy%-30,"LOAD",load%()) create_gadget(2,210,winy%-30,"SAVE",save%()) create_gadget(2,304,winy%-30,cancel$,cancel%()) ' get_prefs!=FALSE REPEAT string_gadget(2,156,winy%-46,25,80,configdir$,exit%) ' test_gadget(2,on1%(),test!) IF test! THEN ! ***** AUTO INDENT ***** autoindent!=NOT autoindent! show_switch(2,autoindent!,156,23,on1%()) ENDIF test_gadget(2,on2%(),test!) ! ***** SEARCH ZOOM ***** IF test! THEN searchzoom!=NOT searchzoom! show_switch(2,searchzoom!,156,37,on2%()) ENDIF test_gadget(2,on3%(),test!) ! ***** SAVE ICON ***** IF test! THEN LET saveicon!=NOT saveicon! show_switch(2,saveicon!,327,23,on3%()) ENDIF test_gadget(2,on4%(),test!) ! ***** SHIFT+DEL ***** IF test! THEN shiftdel_word!=NOT shiftdel_word! show_switch(2,shiftdel_word!,156,93,on4%()) ENDIF test_gadget(2,on5%(),test!) ! ***** BACKUPS ***** IF test! THEN backups!=NOT backups! show_switch(2,backups!,327,51,on5%()) ENDIF test_gadget(2,on6%(),test!) ! ***** STRIP EOL ***** IF test! THEN strip_eol!=NOT strip_eol! show_switch(2,strip_eol!,156,51,on6%()) ENDIF test_gadget(2,on7%(),test!) ! ***** SHOW LF's ***** IF test! THEN showlinefeeds!=NOT showlinefeeds! show_switch(2,showlinefeeds!,156,65,on7%()) ENDIF test_gadget(2,on8%(),test!) ! **** TAB -> SPACE **** IF test! THEN tab2space!=NOT tab2space! show_switch(2,tab2space!,327,65,on8%()) ENDIF test_gadget(2,on9%(),test!) ! **** PP DETECT **** IF test! THEN pp_detect!=NOT pp_detect! show_switch(2,pp_detect!,156,79,on9%()) ENDIF test_gadget(2,on0%(),test!) ! **** CURSOR FLASH **** IF test! THEN flash_gordon!=NOT flash_gordon! show_switch(2,flash_gordon!,327,79,on0%()) ENDIF test_gadget(2,on10%(),test!) ! **** WORD WRAP **** IF test! THEN word_wrap!=NOT word_wrap! show_switch(2,word_wrap!,327,37,on10%()) ENDIF test_gadget(2,on11%(),test!) ! **** STOP AT EOL **** IF test! THEN eol_overflow!=NOT eol_overflow! show_switch(2,NOT eol_overflow!,327,93,on11%()) ENDIF test_gadget(2,on12%(),test!) ! **** BLOCK CURSOR **** IF test! THEN use_underline!=NOT use_underline! show_switch(2,NOT use_underline!,156,107,on12%()) ENDIF test_gadget(2,on13%(),test!) ! **** COLOUR CURSOR **** IF test! THEN alternate_cursor!=NOT alternate_cursor! show_switch(2,alternate_cursor!,327,107,on13%()) ENDIF test_gadget(2,on14%(),test!) ! **** ASL REQS. **** IF test! THEN use_asl!=NOT use_asl! show_switch(2,use_asl!,156,121,on14%()) ENDIF test_gadget(2,on15%(),test!) ! **** ASL REQS. **** IF test! THEN alt_gadgets!=NOT alt_gadgets! show_switch(2,alt_gadgets!,327,121,on15%()) ENDIF test_gadget(2,okay%(),okay!) ! ***** OKAY ***** test_gadget(2,cancel%(),cancel!) ! ***** CANCEL ***** test_gadget(2,save%(),test!) ! ***** SAVE PREFS ***** IF test! THEN file_type(configdir$,filetype%) IF filetype%>0 THEN message("Saving Configuration File...") @save_config_file(configdir$) message("") ELSE inform("Configuration Directory Does Not Exist!") ENDIF ENDIF test_gadget(2,load%(),get_prefs!) ! ***** LOAD PREFS ***** ' IF exit%=2 THEN okay!=TRUE ENDIF UNTIL okay! OR cancel! OR get_prefs! OR abortgadget! test_gadget_keypress(2,okay%(),okay!) ' IF abortgadget! THEN cancel!=TRUE ENDIF ' close_window(2) ENDIF ENDIF ' IF get_prefs! THEN append_filename(configdir$,configfile$,tempfile$) file_type(tempfile$,filetype%) IF filetype%<0 THEN message("Loading Configuration File...") @load_config_file(configdir$) SWAP newres%,screenres% SWAP newcol%,screencolours% SWAP new_wbench!,use_wbench! set_colours change_resolution(FALSE) cancel!=FALSE message("") ELSE file_not_found(tempfile$) cancel!=TRUE ENDIF ENDIF ' IF cancel! THEN autoindent!=old_autoindent! searchzoom!=old_searchzoom! LET saveicon!=old_saveicon! backups!=old_backups! strip_eol!=old_strip_eol! shiftdel_word!=old_shiftdel! showlinefeeds!=old_showlinefeeds! tab2space!=old_tab2space! pp_detect!=old_pp_detect! flash_gordon!=old_flash_gordon! configdir$=old_configdir$ word_wrap!=old_word_wrap! eol_overflow!=old_eol_overflow! alternate_cursor!=old_alternate_cursor! use_underline!=old_use_underline! use_asl!=old_use_asl! alt_gadgets!=old_alt_gadgets! ELSE IF showlinefeeds!<>old_showlinefeeds! THEN get_curpos refresh_page ENDIF update_cur_char init_prop ENDIF ' ' If auto-indenting is off, then symbolic indenting must also be off ' IF NOT autoindent! THEN symbol_indent!=FALSE ENDIF ' ERASE load%(),save%(),on1%(),on2%(),on3%(),on4%(),on5%(),on6%(),on7%(),on8%(),on9%(),on0%(),on10%(),on11%(),on12%(),on13%(),on14%(),on15%() ' set_alternate_cursor update_tab update_num_lock update_case_flag cursor_on RETURN > PROCEDURE definitions ' ' The definitions screen for changing textual thingies ' LOCAL okay!,cancel!,exit%,winy% ' DIM old_drive$(4) ' old_memorysize%=memorysize% old_pageno_style$=pageno_style$ old_prtdevice$=prtdevice$ old_word_wrap%=word_wrap_cutoff% memorysize%=memorysize%-memlow% ' winy%=200 open_window(2,120,20,400,winy%,"Definitions") IF NOT unable_to_open_window! THEN draw_box(2,25,17,400-27,81) draw_box(2,25,88,400-27,165) colour2(2,pen1%,backcol%) text(2,41,30,"Word Wrap CutOff :") text(2,65,44," Buffer Size :") text(2,49,58," Page No Style :") text(2,65,72," Printer :") refresh_number(2,200,44,7,memorysize%) refresh_string(2,200,58,10,pageno_style$) refresh_string(2,200,72,15,prtdevice$) ' FOR l%=0 TO 4 colour2(2,pen1%,backcol%) text(2,50,101+l%*14,"File Requester Drive "+STR$(l%+1)+" :") refresh_string(2,260,101+l%*14,10,drive$(l%)) old_drive$(l%)=drive$(l%) NEXT l% ' IF use_asl! OR use_arp! THEN GRAPHMODE 4 DEFFILL 0,2,4 COLOR backcol% FOR l%=0 TO 4 pbox(2,258,94+l%*14,342,102+l%*14) NEXT l% DEFFILL 1,1,1 GRAPHMODE 1 ENDIF ' create_gadget(2,31,winy%-25,accept$,okay%()) create_gadget(2,304,winy%-25,cancel$,cancel%()) ' casepos%=0 REPEAT number_group(2,200,30,4,3,0,casepos%,word_wrap_cutoff%,exit%) number_group(2,200,44,7,6,1,casepos%,memorysize%,exit%) string_group(2,200,58,10,80,2,casepos%,pageno_style$,exit%) string_group(2,200,72,15,80,3,casepos%,prtdevice$,exit%) ' IF (NOT use_asl!) AND (NOT use_arp!) THEN FOR l%=0 TO 4 drive$=drive$(l%) string_group(2,260,101+l%*14,10,80,l%+4,casepos%,drive$,exit%) drive$(l%)=drive$ IF INSTR(drive$(l%),":")=0 THEN drive$=drive$+":" drive$(l%)=drive$ refresh_string(2,260,101+l%*14,10,drive$) ENDIF NEXT l% ENDIF ' memorysize%=MAX(memorysize%,10000) word_wrap_cutoff%=MAX(word_wrap_cutoff%,10) IF TRIM$(pageno_style$)="" THEN pageno_style$=pageno_symbol$ ENDIF IF TRIM$(prtdevice$)="" THEN prtdevice$="PRT:" ENDIF ' SELECT casepos% CASE 0 refresh_number(2,200,30,4,word_wrap_cutoff%) CASE 1 refresh_number(2,200,44,7,memorysize%) CASE 2 refresh_string(2,200,58,10,pageno_style$) CASE 3 refresh_string(2,200,72,15,prtdevice$) ENDSELECT ' IF (NOT use_asl!) AND (NOT use_arp!) THEN casepos%=(casepos%+9+exit%) MOD 9 ELSE casepos%=(casepos%+4+exit%) MOD 4 ENDIF test_gadget(2,okay%(),okay!) ! ***** OKAY ***** test_gadget(2,cancel%(),cancel!) ! ***** CANCEL ***** ' IF exit%=2 THEN okay!=TRUE ENDIF UNTIL okay! OR cancel! OR abortgadget! test_gadget_keypress(2,okay%(),okay!) ' IF abortgadget! THEN cancel!=TRUE ENDIF ' close_window(2) ' IF cancel! THEN pageno_style$=old_pageno_style$ prtdevice$=old_prtdevice$ memorysize%=old_memorysize% word_wrap_cutoff%=old_word_wrap% FOR l%=0 TO 4 drive$(l%)=old_drive$(l%) NEXT l% ELSE memorysize%=memorysize%+memlow% IF memorysize%<>old_memorysize% THEN new_memory_size(old_memorysize%,TRUE) ENDIF update_cur_char init_prop ENDIF cursor_on ENDIF ' ERASE old_drive$() RETURN > PROCEDURE timed_saves ' winy%=111 open_window(2,120,20,400,winy%,"Auto Save") IF NOT unable_to_open_window! THEN draw_box(2,25,17,400-27,68) colour2(2,pen1%,backcol%) text(2,40,30,"Save Document Every (Mins) :") text(2,40,46," Facility Activated :") text(2,40,62," Append .SAVE extension :") ' old_timed_save!=timed_save! old_timed_ext!=timed_ext! old_timed_mins%=timed_mins% ' ' show_switch(2,timed_save!,270,37,gad1%()) show_switch(2,timed_ext!,270,53,gad2%()) create_gadget(2,31,winy%-30,accept$,okay%()) create_gadget(2,304,winy%-30,cancel$,cancel%()) ' REPEAT number_gadget(2,280,30,5,4,timed_mins%,exit%) timed_mins%=MAX(timed_mins%,1) test_gadget(2,okay%(),okay!) test_gadget(2,cancel%(),cancel!) test_gadget(2,gad1%(),hit!) IF hit! THEN timed_save!=NOT timed_save! show_switch(2,timed_save!,270,37,gad1%()) ENDIF test_gadget(2,gad2%(),hit!) IF hit! THEN timed_ext!=NOT timed_ext! show_switch(2,timed_ext!,270,53,gad2%()) ENDIF IF exit%=2 THEN okay!=TRUE ENDIF UNTIL okay! OR cancel! OR abortgadget! test_gadget_keypress(2,okay%(),okay!) ' IF cancel! OR abortgadget! THEN timed_save!=old_timed_save! timed_ext!=old_timed_ext! timed_mins%=old_timed_mins% ELSE IF (timed_save!<>old_timed_save!) OR (timed_mins%<>old_timed_mins%) last_time_save%=TIMER ENDIF ' close_window(2) ENDIF ' RETURN