; Disk menu with 2 column display and utility options    6/13/11
; Requires altutils.ipl/fcam.ipl/sham.ipl
; HP BASIC support is built-in
; For MSU BASIC support msupatch.ipl is recommended
; Requires XDOS v1.26 or greater w/ fixed XDEL/XLOAD
; Requires PRESET word (HP-IPL/OS v1.11+)
;
; _DM - controls printing info before running binaries
; _RC - controls how the new CONSOLE behaves.
; CONSOLE - if _RC is 0 then does normal CONSOLE, otherwise uses
; string on X stack to run the word, forgets it, then reruns DMENU.
; This causes a duplicate CONSOLE but I don't care, that's allowed.
; DMENU - lists files beginning with # @ and $ as menu options,
; the prefixes are not displayed in the name. Supported file types...
;   # - text file, display with XSHOW
;   @ - system binary, load/run with XLOAD
;   $ - ipl run file, load w/XLOAD, run, forget, return to menu
; !DM - autostart word that runs DMENU, forget if not wanted
;
; In the "multi-boot" 7906/IDE build the !DM word is usually replaced
; with a !DMI word that runs the menu only if a disk driver detected...
;   OCTAL DEFINE !DMI
;   %DT GET IFNZ #0 S>SR DMENU ENDIF END
; When updating DMENU in such a build (like in the 7906 sim package)
; at the prompt do...
;   "!DMI" 0 STASH  (saves existing !DMI word to data block 0)
;   FORGET _DM      (press Y to confirm)
;   "DM2.IPL" XLOAD (assuming on disk, otherwise attach to ptr and LOAD)
;   FORGET !DM      (press Y to confirm)
;   0 FETCH         (restores the previous !DMI word)
;
; The original dmenu.ipl was modified from rcontrol.ipl (3/29/07),
; an earlier work used for booting and fixing a simulated TSB-E system.
; This updated version implements a 2-column display to avoid scrolling
; and includes many more file operation features including a submenu with
; an import function for text files that doesn't require knowing length.
; This can only be used for non-binary files and to work the file either
; needs at least 1 trailing zero, or the simulator must be set to provide
; trailing zeros [d ptr trllim 40]. For real hardware the PTR emulator
; transfer program needs to send nuls if data requested after EOF.
;
; Supports saving BASIC programs entered into the 31KW version of MSU BASIC,
; if MSUPATCH is present prompts to run it to change the startup text and/or
; change the correction character ("_") to/from a regular ascii-8 backspace.
; The 31KW MSU BASIC is modified to not clear memory to make saving easier.
;
; Supports patching HP BASIC programs as well, optionally changing loc 3
; to 2027 to re-enter or 5137 to auto-execute. Note.. first use the import
; menu then use Import ABS to save a stock HP BASIC to disk to add the run
; vector at locs 2/3 and patch BYE to return to HP-IPL/OS.
;
; 6/13/11 changed HPBASIC re-enter from 2050 to 2027
;         changed message about BCS CRLF (only applies to stock apps)
; 6/5/10 6/9/10   added HPBASIC support, fixed to show more files
; 8/3/08 8/19/08  initial version from dmenu.ipl, show build version
;
OCTAL
VARIABLE _DM
;_DM variable controls printing of binary instructions...
 _DM 1 PUT  ;print once then don't print unless disk rebooted
;_DM 2 PUT  ;always print
;_DM 0 PUT  ;never print
;set _DM and DGEN to set preference
VARIABLE _RC
_RC #0 PUT
; if _RC is 0 then does a normal CONSOLE and nothing else.
; if _RC is not 0, then name of word to run and forget is
; expected to be on the X stack, executes it then forgets it.
; if a word named DMENU exists it is run after forgetting.
DEFINE CONSOLE
CONSOLE ;execute existing console to reset console/ms redirection
_RC GET IFNZ ;if _RC is not zero
 _RC #0 PUT ;reset it
 $DUP $DEFADR DUP IFZ ;if string is not a valid word
  "RUN ERROR" $PRINT $DROP DROP ;display error and clean up
 ELSE
  EXECUTE ;execute word address still on stack - program runs
  $DEFADR DUP IFZ ;if string is not valid (program error)
   "FORGET ERROR" $PRINT DROP ;display error and clean up
  ELSE
   4 SUB #0 PUT ;put a zero 4 locations before address, forgetting it
   "DMENU" $DEFADR DUP IFZ DROP ELSE EXECUTE ENDIF ;rerun DMENU if it exists
  ENDIF
 ENDIF
ENDIF
END
; helper word "string" T$FILE - if non-prefixed file exists pushes 1,2,3
; 1=$ binary 2=# text 3=$ IPL (in order of detection if multiple types exist)
; if found pushes string with full name, if not found just pushes 0
DEFINE T$FILE
#0 ;found/type flag
$DUP "@ " $SWAP $CAT $DUP GetFile IFNZ DROP DROP DROP #1 ELSE
 $DROP $DUP "# " $SWAP $CAT $DUP GetFile IFNZ DROP DROP DROP 2 ELSE
  $DROP $DUP "$ " $SWAP $CAT $DUP GetFile IFNZ DROP DROP DROP 3 ELSE
   $DROP
  ENDIF
 ENDIF
ENDIF
END
; disk menu - scans directory for files with names beginning
; with # @ or $ for text, binary, or run file. For run files
; the name after $ must be the name of the first word defined
; and also the word that must be run to start the application. Combine
; multiple-word apps into one word if necessary, or use something like
; "NAME" $DEFADR EXECUTE to execute following words so the main word
; can be defined first.
; Uses mem locs 150,155,156 for temp storage
; Extensively modified from previous DMENU in the search for "perfection"
; (of course never really achieved but loads of code-hacking fun to try!)
DEFINE DMENU
_RC #0 PUT ;clear failed loads after page errors
DO ;until user exits menu
 #0 ;master exit flag
 CRLF CRLF ;mod 8/18/08 to print version string
 11 75 $CREATE $PRINT 40 DUP PCHR ;print "========= ", save space
 2003 2014 +DO INDEX GET S>X +LOOP ;copy version words to X stack
 24 S>X 13 S>X $TRIM $PRINT ;fix up and print version string
 PCHR 26 75 $CREATE $PRINT  ;fill out w/= to past 2nd column
 ; a bit over-the-top but useful.. and sportful!
 @BLK GET DUP 1777 ADD +DO INDEX 15 PUT +LOOP ;fill block 0 with CR
 #0 OUTBLOCK ;redirect MS to block #0
 >MS ;redirect console out to MS then fill block(s) with disk dir...
;11/17/07... XDIR output bigger than 1 block if too many files,
;recoding to record just filenames
 GetVol VolInfo GET IFNZ
  VolInfo INC INC GET VolInfo INC GET SBLA WKBUF R-1K
  WKBUF
  #0 VolInfo GET DEC +DO ;loop thru all dir entries
   DUP GET IFNZ ;if not zero
    DUP GET 20040 SUB IFNZ ;if not spaces
     #0 7 +DO DUP INDEX ADD GET PWRD +LOOP CRLF ;print filename
    ENDIF
   ENDIF
   20 ADD ;increment ptr
  +LOOP
  DROP ;ptr
 ENDIF
 CONSOLE ;reset console and MS redirection
 #0 INBLOCK ;redirect MS input from block #0
 101 ;letter counter, ascii for "A"
 155 #0 PUT ;even/odd flag
 DO ;while stuff to do
  MS$IN ;get a line from dir listing
  $LEN ;push length (leave on stack for WHILE)
  DUP IFNZ ;if line not empty
   $HEAD ;remove 1st letter of filename
   CASE
   = 100 #1 "Binary  "  ;@
   = 44  #1 "Run IPL "  ;$
   = 43  #1 "Text    "  ;#
   DEFAULT #0
   ENDCASE
   IFNZ ;if supported type
    155 GET IFZ ;if even entry  2-column disp. 3/13/08
     CRLF 155 #1 PUT ;new line, next time space
    ELSE
     "      " $PRINT 155 #0 PUT ;spaces, next time crlf
    ENDIF
    SWAP DUP PCHR ") " $PRINT $PRINT ;print choice and type
    #0 17 $SLICE $PRINT ;print the name
    INC SWAP ;increment letter counter
    OVER 141 SUB IFZ ;if past ascii 96 (`) then stop...
     DROP #0 ;pretend there's no more files
    ENDIF
   ENDIF
  ENDIF
  $DROP ;drop the dir line string
 WHILE
 ;last letter code + 1 on stack
 CONSOLE CRLF ;reset console and MS redirection, new line
 ;now have to get user input, find that dir line, figure out
 ;what to do with it
 "1) Exit to prompt  2) Clear alt and halt   3) Load ABS from PTR"
 $PRINT CRLF
 "4) Delete file     5) Rename bin/txt file  6) Import/Export file"
 $PRINT CRLF
 ;only display next options if binary in alt mem  3/13/08
 156 #0 PUT ;detection flag
 2 AGET 124003 SUB IFZ
  "7) Save binary     8) Display binary data  9) Punch ABS to PTP"
  $PRINT CRLF 156 #1 PUT ;set flag for later
 ENDIF
 DO ;until valid key
  20015 PWRD "Press a key: " $PRINT ;mod 8/19/08, reprint prompt if
  CHRIN ;get a key                                invalid keypress
  DUP CASE
  = 61 ;if a 1 - exit menu
    CRLF DROP DROP DROP #1 #1 #1 ;exit DMENU
  = 62 ;if a 2 - clear alt except for halt then save/swap system
    PRESET ;turn off interrupts and everything
    ALTSAVE ;just to get the swapper prog at 77000
    ZAM CONSOLE ;zero alt, reset to PTR
    2 102077 APUT 3 124060 APUT 60 77000 APUT ;patch alt to halt
    CRLF CRLF "Run 77000 to return to HP-IPL/OS" $PRINT CRLF
    77000 RUN ;save HP-IPL/OS and halt to empty system
  = 63 ;if a 3 - load ABS  3/13/08 mod 8/18/08 to provide a way out
    CRLF "Clear or Overlay? (C/O) " $PRINT CHRIN CRLF
    DUP 103 SUB IFZ        ;if C pressed
     ALTSAVE ZAM DROP 117  ; add swapper, clear alt, change key to O
    ENDIF
    117 SUB IFZ            ;if C or O pressed...
     "Halt to attach and detach? " $PRINT CHRIN CRLF
     131 SUB IFZ #1 ELSE #0 ENDIF 150 SWAP PUT ;set halt flag
     150 GET IFNZ "Attach PTR file and continue" $PRINT CRLF HLT ENDIF
     ABSLOAD 150 GET IFNZ HLT ENDIF
     2 AGET 124003 SUB IFZ ;if binary
      77000 GET 105734 SUB IFZ ;if swapper in mem
       "Run binary? (Y/N) " $PRINT CHRIN CRLF
       131 SUB IFZ
        "Halt and run from 77000 to exit" $PRINT CRLF CRLF
        77000 RUN ;execute swapper
       ENDIF
      ENDIF
     ENDIF
    ENDIF
  = 64 ;if a 4 - delete file
    CRLF "File to delete: " $PRINT $IN $TRIM
    $LEN IFNZ
     T$FILE   ;check and push type and if it exists full name
     IFNZ XDEL ENDIF ;if found prompt to delete
    ENDIF
    $DROP ;original entry
  = 65 ;if a 5 - rename txt/binary file (not IPL)
    CRLF "File to rename: " $PRINT $IN $TRIM
    $LEN IFNZ ;if a filename entered
     T$FILE   ;check and push type and if it exists full name
     DUP IFZ DROP ELSE ;if it exists
      DUP 3 SUB IFZ ;if IPL
       "Can't rename IPL app" $PRINT
       DROP $DROP
      ELSE
       "New name      : " $PRINT $IN $TRIM
       $LEN IFZ DROP $DROP $DROP ELSE ;only if new name entered 3/21/08
        CASE = 1 "@ " = 2 "# " ENDCASE $SWAP $CAT XREN
       ENDIF
      ENDIF
     ENDIF
    ENDIF
    $DROP ;original entry
  = 66 ;if a 6 - import/export menu  mod 8/18/08 to shorten text
    CRLF CRLF
    "1) Import ABS from PTR" $PRINT CRLF
    "2) Export ABS to PTP" $PRINT CRLF
    "3) Import text from PTR" $PRINT CRLF
    "4) Export text to PTP" $PRINT CRLF
    "5) List disk directory" $PRINT CRLF
    "Press 1-5 or any other key to exit: " $PRINT CHRIN CRLF
    CASE
    = 61
    "Binary file to import (@ FILE for menu): " $PRINT $IN $TRIM
    $LEN IFZ $DROP ELSE
     $DUP GetFile ;find file location
     IFNZ ;if exists prompt to delete...
      "File Exists. " $PRINT DROP DROP $DUP XDEL CRLF
     ENDIF
     $DUP GetFile ;make sure it doesn't exist now
     IFNZ DROP DROP $DROP ELSE ;if user said no ignore otherwise...
      "Halt to attach and detach? " $PRINT CHRIN CRLF
      131 SUB IFZ #1 ELSE #0 ENDIF 150 SWAP PUT ;set halt flag
      150 GET IFNZ "Attach PTR file and continue" $PRINT CRLF HLT ENDIF
      ABS2F 150 GET IFNZ HLT ENDIF
     ENDIF
    ENDIF
    = 62
    "Binary file to export (@ FILE for menu): " $PRINT $IN $TRIM
    $LEN IFZ $DROP ELSE
     F2ABS ;already prompts to halt
    ENDIF
    ;text import/export functions 3/14/08
    = 63
    "Text file to import (# FILE for menu): " $PRINT $IN $TRIM
    $LEN IFZ $DROP ELSE
     $DUP GetFile ;find file location
     IFNZ ;if exists prompt to delete...
      "File Exists. " $PRINT DROP DROP $DUP XDEL CRLF
     ENDIF
     $DUP GetFile ;make sure it doesn't exist now
     IFNZ DROP DROP $DROP ELSE ;if user said no ignore otherwise...
      "Halt to attach and detach? " $PRINT CHRIN CRLF
      131 SUB IFZ #1 ELSE #0 ENDIF 150 SWAP PUT ;set halt flag
      150 GET IFNZ "Attach PTR file and continue" $PRINT CRLF HLT ENDIF
      ZAM ;clear alt mem
      350 DUP GET ;push MS in vector (PTR), save '350'
      2 MSUSER ;redirect MS to alt mem
      PUT ;restore MS in to PTR, leaving MS out directed to alt mem
      DO  ;skip leader if it exists
       MSBIN DUP IFNZ MSBOUT #1 ENDIF  ;fixed 8/17/08
      UNTIL ;non-zero received
      "Importing bytes from PTR..." $PRINT
      #1 ;start byte count at 1 byte
      DO  ;while non-zero data is received
       MSBIN DUP IFNZ ;if non-zero (save for while)
        DUP MSBOUT ;write to altmem
        SWAP INC SWAP ;increment byte count
        OVER 3777 AND IFZ 56 PCHR ENDIF ;print another dot every 2kbytes
       ENDIF
      WHILE
      #0 MSBOUT ;make sure MSUSER flushes its buffer
      150 GET IFNZ HLT ENDIF
      CONSOLE ;restore MS vectors to papertape
      #0 OVER $DSTR $PRINT " (dec) bytes received" $PRINT CRLF
      AM2F CRLF ;save to file
     ENDIF
    ENDIF
    = 64
    "Text file to export (# FILE for menu): " $PRINT $IN $TRIM
    $LEN IFZ $DROP ELSE
     $DUP GetFile IFZ "Not found" $PRINT CRLF $DROP ELSE
      DROP DROP
      "Halt to attach and detach? " $PRINT CHRIN CRLF
      131 SUB IFZ #1 ELSE #0 ENDIF 150 SWAP PUT ;set halt flag
      150 GET IFNZ "Attach PTP file and continue" $PRINT CRLF HLT ENDIF
      F2MS CRLF
      150 GET IFNZ "Detach PTP and continue" $PRINT CRLF HLT ENDIF
     ENDIF
    ENDIF
    = 65 CRLF XDIR ;list directory
    ENDCASE
  = 67 ;if a 7 - save binary  3/13/08
    156 GET IFNZ ;if binary in alt mem
     CRLF ;mod 8/11/08 to move crlf, mod 8/19/08 to make MSUPATCH optional
     2012 AGET 60114 SUB IFZ ;detect the 31KW version of MSU BASIC
      67337 AGET 60373 SUB IFZ ;if detected...
       "MSUPATCH" $DEFADR ;push word address of MSUPATCH utility
       DUP IFZ DROP ELSE  ;if loaded in dictionary prompt to patch...
        "Run MSUPATCH? " $PRINT CHRIN CRLF
        131 SUB IFZ EXECUTE ELSE DROP ENDIF
       ENDIF 
      ENDIF
     ENDIF
     ;HP BASIC support 6/5/10
     100 AGET 124201 SUB IFZ
      105 AGET 2200 SUB IFZ  ;if HP BASIC detected
       "1)autorun 2)preserve or no change:" $PRINT CHRIN CRLF
       CASE = 61 5137 = 62 2027 DEFAULT #0 ENDCASE ;6/13/11
       DUP IFZ DROP ELSE 3 SWAP APUT ENDIF 
      ENDIF
     ENDIF ;end HP BASIC support mod
     "File to save: " $PRINT $IN
     $LEN IFZ $DROP ELSE ;if something was entered  fix 8/19/08
      "@ " $SWAP $CAT ;add binary mark to name
      $DUP GetFile ;find file location
      IFNZ ;if exists prompt to delete...
       "File Exists. " $PRINT DROP DROP $DUP XDEL CRLF
      ENDIF
      $DUP GetFile ;make sure it doesn't exist now
      IFNZ DROP DROP $DROP ELSE ;if user said no ignore otherwise...
       174000 AM2F ;save to disk
      ENDIF CRLF ;menu will redisplay
     ENDIF
    ELSE DROP #0 ENDIF ;no binary, ignore key
  = 70 ;if a 8 - dump binary
    156 GET IFNZ ;if binary in alt mem
     CRLF CRLF
     "Enter ALL to dump everything" $PRINT CRLF
     "Just Enter to return to menu" $PRINT CRLF
     SHAM
    ELSE DROP #0 ENDIF ;no binary, ignore key
  = 71 ;if a 9 - punch ABS  3/13/08
    156 GET IFNZ ;if binary in alt mem
     CRLF AM2ABS ;do it
    ELSE DROP #0 ENDIF ;no binary, ignore key
  > 100 ;if at least an A
    OVER ;push last code + 1
    OVER ;push code just pressed
    SWAP SUB IF<0 ;if code < last + 1 it's valid
     CRLF ;for neatness
     #0 INBLOCK ;redirect MS from block 0
     ;stack = master exit, last code + 1, selected code
     101 ;push starting code
     DO ;until selected dir line found
      MS$IN ;get dir line
      #0 17 $SLICE $TRIM $SWAP $DROP ;turn into just filename (bf 12/11/07)
      #0 $GET CASE ;action depends on 1st char
      = 43 ;# if text file
      OVER OVER SUB IFZ ;if the selected file
       XSHOW ;display that file
       #1 ;don't loop for more
      ELSE $DROP INC #0 ENDIF ;not the file keep looking
      = 44 ;$ if run-and-forget IPL program
      OVER OVER SUB IFZ ;if the selected file
       CONSOLE ;undo redirection
       $DUP $HEAD DROP $TRIM ;make a string containing word name
       $SWAP ;put actual filename on top
       _RC #1 PUT ;we want to run and forget
       XLOAD ;hopefully run and forget
       S>Z
       ROT SWAP DROP #1 SWAP ROT ;exit menu to do the load
       Z>S
       #1 ;don't loop for more
      ELSE $DROP INC #0 ENDIF ;not the file keep looking
      = 100 ;@ if a binary file
      OVER OVER SUB IFZ ;if the selected file
       CRLF
       _DM GET IFNZ ;_DM must be non-zero  message changed 6/13/11
        "If binary doesn't support exit/reboot/etc then" $PRINT CRLF
        "halt (ctrl-E), run 77000 to return to HP-IPL/OS." $PRINT CRLF
        "Stock BCS apps require CRLF enters, if terminal" $PRINT CRLF
        "can't be set that way press ctrl-J after enter." $PRINT CRLF
        _DM GET #1 SUB IFZ _DM #0 PUT ENDIF ;if _DM=1 make _DM=0
       ENDIF
       CRLF XLOAD ;load and run it
       #1 ;don't loop for more (shouldn't get here)
      ELSE $DROP INC #0 ENDIF ;not the file keep looking
      ;end of conditions
      DEFAULT $DROP #0 ;not a match so drop dir line and keep looking
      ENDCASE
      ;match must occur or endless loop ugliness but should be fine :)
     UNTIL
     DROP ;code counter
    ELSE
     DROP #0 ;invalid key try again
    ENDIF
  DEFAULT DROP #0 ;replace key with 0 to try again
  ENDCASE
 UNTIL
 DROP ;max letter code
UNTIL ;menu is exited
END
;
DEFINE !DM
#0 S>SR ;so CHESS doesn't freak 9/2/07
DMENU
END
;
CONSOLE
~TERMINATE~