; Custom#Menu copyright 1990-92 Mountain Software - all rights reserved
; 5/7/92 version 1.9
;------

(if (boundp 'xload) (progn
  (princ "Loading ADS Custom#Menu...")
  (xload"cmenu")
);else
(progn
  (princ "Loading AutoLISP Custom#Menu...")

;------
Initialize global variables
;------

(setq _typ      "Command"
      _lstyp	_typ
      _lblk	nil
)

;------
; our error routine
;------

(defun cm:err (s)
  (if f (setq f (close f)))
  (grtext)  (redraw)
  (princ (strcat "\nCMenu Error: " s))
  (setq *error* olderr)
  (princ)
)

;------
; Block insert routine
;------

(defun doinsert (/ _blk blkrec lstrec s xscale yscale rot)
    (if (null _lblk) (progn
	(setq blkrec (tblnext "BLOCK" T)          ;retrieve first block
	      lstrec blkrec)
	(while (boundp 'blkrec)
	  (setq blkrec (tblnext "BLOCK"))
	  (if (boundp 'blkrec) (setq lstrec blkrec))
	)
	(if (boundp 'lstrec) (setq _lblk (cdr (assoc 2 lstrec))))
    ))
    (if (null _lblk) (progn
      (initget 1)
      (setq s "\nBlock name: ")
    )
      (setq s (strcat "\nBlock name[" _lblk "]:"))
    )
    (setq _blk (getstring s))
    (if (= _blk "") (setq _blk _lblk))
    (setq xscale (strcat(getstring "X scale factor \"\\\" to prompt <1>:")))
    (if (= xscale "") (setq xscale "1;")
      (if(/= xscale "\\") (setq xscale (strcat xscale ";"))))
    (setq yscale (getstring "Y scale factor \"\\\" to prompt (default=X):"))
    (if (= yscale "") (setq yscale ";")
      (if(/= yscale "\\") (setq yscale (strcat yscale ";"))))
    (setq rot	 (getstring "Rotation Angle \"\\\" to prompt <0>:"))
    (if (= rot "") (setq rot "0;") ;else
      (if(/= rot "\\") (setq rot (strcat rot ";"))))
    (if (boundp '_blk)
      (setq _cmd (strcat _blk ";\\" xscale yscale rot))
      (setq _cmd nil))
)

;------
; Command input function
;------

(defun docommand ()
    (princ(strcat
      "\nSpecial Menu Command Characters:"
      "\n^C^C = Cancel, ^P = Toggle menuecho, ; = Return, \\ = Pause for input"))
    (setq _cmd (getstring t "\nEnter menu command: "))
)

;------
; AutoLisp function
;------

(defun dolisp (/ al_fn al_cmd)
    (setq al_fn  (getstring "\nAutolisp filename: ")
	  al_cmd (getstring(strcat "\nAutolisp command to execute "
				   "\".\" for none[" al_fn "]: ")))
    (if (= al_cmd "") (setq al_cmd al_fn))
    (if (= al_fn "")
      (setq _cmd al_cmd) ;else
      (if (= al_cmd ".")
	(setq _cmd (strcat "^C^C^P(load\"" al_fn "\") ^P"))
	(setq _cmd (strcat "^C^C^P(cond ((null "
		     (if(= (chr 40) (substr al_cmd 1 1))
		       (substr al_cmd 2 (-(strlen al_cmd)2))
		       (strcat "c:" al_cmd)
		     )
		     ") (load \""
		     al_fn "\")) (t (princ))) "
		     al_cmd " ^P"))
      )
    )
)

;------
; ADS function
;------

(defun doads (/ al_fn al_cmd)
    (setq al_fn  (getstring "\nADS filename: ")
	  al_cmd (getstring(strcat "\nADS command to execute "
				   "\".\" for none[" al_fn "]: ")))
    (if (= al_cmd "") (setq al_cmd al_fn))
    (if (= al_fn "")
      (setq _cmd al_cmd) ;else
      (if (= al_cmd ".")
	(setq _cmd (strcat "^C^C^P(xload\"" al_fn "\") ^P"))
	(setq _cmd (strcat "^C^C^P(cond ((null "
		     (if(= (chr 40) (substr al_cmd 1 1))
		       (substr al_cmd 2 (-(strlen al_cmd)2))
		       (strcat "c:" al_cmd)
		     )
		     ") (xload \""
		     al_fn "\")) (t (princ))) "
		     al_cmd " ^P"))
      )
    )
)

;------
; Write Parameter file
;------

(defun writedat (/ f mfn)
    (setq f (open "cmenu.dat" "w"))
    (if (boundp 'f) (progn
	(if (null(setq mfn (findfile(strcat(getvar "MENUNAME")".MNU"))))
	(progn
	  (princ "\nUnable to locate menu file on the AutoCAD library path")
	  (princ(strcat(getvar "MENUNAME") "\n") f)
	) ;else
	  (princ (strcat mfn "\n") f)
	)
	(princ (strcat
	  (getvar "DWGPREFIX") "\n"     (getvar "ACADPREFIX") "\n"
	  _ttl "\n"                     (itoa mode) "\n"
	  (itoa item) "\n"              insovr "\n"
	  _typ "\n"                     _cmd "\n") f)
	(close f)
  ) (princ "\nError opening CMENU.DAT"))
)

;------
; append a command to command string
;------

(defun add_cmd(subcmd)
   (setq _cmd  (strcat _cmd subcmd))
)

(defun clr_menu(start cnt)
  (repeat cnt (grtext (setq start (1+ start)) " "))
)

;------
; Learn routine - original author unknown
;------

(defun learn ( / last n point string getinput inkey sl)
  (graphscr)
  (mapcar 'grtext
    '(-1 -2 4 5 6 7 8)
    '("***<< Learn Mode Active >>***" "[ Menus are disabled ]"
      "******" "Learn" "Mode" "Active" "******")
  )
  (clr_menu -1 4)
  (clr_menu 8 17)
  (terpri) (prompt(strcat
    "Enter commands from keyboard or pick point from digitizer, <ESC> to end:"
    "\nLEARN: "))
  (setq getinput T
	string	 ""
	point	 nil)
  (setvar "CMDECHO" 1)
  (while (= getinput t)
    (setq inkey (grread))
    (cond
      ;*---- key press
      ((= (car inkey) 2)
	(kbprocess))
      ;*---- point pick
      ((and (= (car inkey) 3) (= string ""))
	(progn
	  (setq point (cadr inkey))
	  (command point)
	  (add_cmd "\\")
	  (prompt "\nLEARN: ")
	)
      )
      ;*---- user selected a menu item
      (T   (prompt(strcat
	   "\nError: Keyboard commands and point picks only, please.\nLEARN: "
	   string))
      )
    );cond
  );while
  (setq sl (strlen _cmd))
  (if(> sl 0) (progn
    (setq last (substr _cmd sl 1))
    (if(or(= last "\\")(= last ";"))
      (setq _cmd (strcat "^C^C^P" _cmd "^P"))
      (setq _cmd (strcat "^C^C^P" _cmd " ^P"))
    )
  ))
  (setvar "CMDECHO" 0)
)

;------
; process the keyboard data from grread
;------

(defun kbprocess ( / char prmpt)
  (setq char (cadr inkey))		; get keyboard character
  (cond
    ;*--- backspace
    ((= char 8)
      (if(>(strlen string) 0) (progn
	(setq string (substr string 1 (1- (strlen string))))
	(prompt(strcat "\nCommand: " string))
      ))
    )
    ;*--- escape
    ((= char 27)
      (setq getinput nil))
    ;*--- Enter or space
    ((or(= char 13)(= char 32))
      (if (= (strcase string) "PAUSE") (progn
        (setq  prmpt  (getstring T "\nEnter text for menu prompt: ")
	       string (getstring "\nEnter current response to ACAD prompt: ")
	)
	(command string)
	(if(>(strlen prmpt) 0)
	  (setq string (strcat "(terpri)(prompt \""  prmpt  "\")(princ) \\" ))
	;else
	  (setq string "\\")
	)
      );else
      (progn
	(if (=(substr string 1 1) (chr 40)) (progn ;AutoLISP function entered
	  (eval(read string))
	  (setvar "CMDECHO" 1)
	  (prompt "\nResuming learn after AutoLISP call...")
	) ;else
	(progn
	  (terpri)
	  (command string)
	))
	(setq string(strcat string (if(= char 13) ";" " ")))
      ))
      (add_cmd string)
      (setq string "")
      (prompt "\nLEARN: ")
    )
    ;*--- default, add key to string
    (T
      (setq string (strcat string (chr char)))
      (prompt (chr char))
    )
  )
)

;------
; Main
;------

(defun C:CMENU (/ cecho trk done bakfile olderr)
  (princ "\nCMenu initializing...")
  (setq cecho (getvar "CMDECHO")
	_ttl  ""
	_cmd  ""
        olderr *error*
	*error* cm:err
  )
  (setvar "CMDECHO" 0)
  (command "MENU" "")
  (graphscr)
  (princ "\n\n\nPick Tablet, Button or Screen Menu Location with cursor...")
  (setq trk	(grread)
	mode	(car trk)
	item	(cadr trk)
	done	nil
  )
  (cond ((= mode 4)
	    (if (< item 1000)	(princ "\nScreen Menu selected ") ;else
				(princ "\nPopUp Menu selected "))
	)
	((= mode 6) (princ "\nButtons selected "))
	((= mode 7) (princ "\nTABLET1 selected "))
	((= mode 8) (princ "\nTABLET2 selected "))
	((= mode 9) (princ "\nTABLET3 selected "))
	((= mode 10) (princ "\nTABLET4 selected "))
	((= mode 11) (princ "\nAUX1 selected "))
	((= mode 13) (princ "\nKeyboard Menu selected "))
	(t  (setq done t))
  )
  (if (not done) (progn
    (if (and (>= mode 6) (<= mode 11))
      (setq insovr "Overwrite") ;else
    (progn
      (initget 0 "Add Insert Overwrite Delete Edit Undo")
      (setq insovr (getkword (strcat "\nAdd/Insert/Overwrite/Delete/Edit/Undo[Insert]: ")))
      (if (null insovr) (setq insovr "Insert"))
    ))
    (if (and(/= insovr "Delete")(/= insovr "Undo")(/= insovr "Edit")) (progn
      (princ "\nSpecial Titles:\n ~-- = Horizontal line in PopUp, Blank title = Command used for title")
      (setq _ttl (getstring t "\nEnter Menu Title: "))
      (initget 0 "AutoLisp ADS Insert Command Learn")
      (setq _lstyp _typ
	    _typ (getkword(strcat "\nAutoLisp/ADS/Insert block/Command/Learn[" _lstyp "]: ")))
      (if (null _typ) (setq _typ _lstyp))
      (cond
	((= _typ "Insert")   (doinsert))
	((= _typ "AutoLisp") (dolisp))
	((= _typ "ADS") (doads))
	((= _typ "Learn")    (learn))
	(t		     (docommand))
      )
    ))
    (if(/= insovr "Undo") (progn
      (writedat)
      (if (= _typ "Learn") (command "" ""))     ;end any pending prompts
      (command "SHELL" "CMENU")
    ) ;else
    (progn
      (setq bakfile (findfile (strcat(getvar "MENUNAME")".cmu")))
      (if (not bakfile) (princ "\nNo backup file found")
	(command "SH" (strcat "copy " bakfile " "
	  (findfile (strcat(getvar "MENUNAME")".mnu"))))
      )
    ))
    (setvar "CMDECHO" 1)
    (command "MENU" "")
    (princ "\ndone!")
  ))
  (setvar "CMDECHO" cecho)
  (setq *error* olderr)
  (princ)
)
(princ "\nCMenu v1.9 loaded - Enter \"CMENU\" to run")
)); end (if(ads))
(princ)