;;; -*- Mode: Lisp; Package: USER; Last modified: "2007/12/31 01:12:21"; -*-
;;;
;;; This file is not part of xyzzy.
;;;
;;;   nadesiko-mode.l --- 側偱偟偙儌乕僪
;;;
;;;     by HIE Masahiro <madoinu@ybb.ne.jp>
#|

仭奣梫

  擔杮岅僾儘僌儔儈儞僌尵岅 側偱偟偙 (http://nadesi.com/) 曇廤梡偺
  儊僕儍乕儌乕僪偱偡丅


仭僀儞僗僩乕儖

  1. nadesiko-mode.l 傪 site-lisp 偵僐僺乕偡傞丅

  2. 昁梫偵墳偠丆僶僀僩僐儞僷僀儖偡傞丅

       M-x byte-compile-file

  3. .xyzzy 偐 siteinit.l 偵埲壓偺婰弎傪捛壛偡傞丅

      (require "nadesiko-mode")
      (pushnew '("\\.nako" . nadesiko-mode) *auto-mode-alist* :test 'equal)

  4. xyzzy 傪嵞婲摦偟丆愝掕傪斀塮偝偣傞丅
     siteinit.l 偵婰弎偟偨応崌偼嵞僟儞僾傕偡傞丅


仭僉乕僶僀儞僪



仭愝掕椺

  ;;; 側偱偟偙傪 C:/nadesiko/ 偵僀儞僗僩乕儖偟偨応崌
  (defvar *nadesiko-path* "C:/nadesiko/")


仭拲堄帠崁

丒儊僯儏乕偺 [幚峴] 偼丆僶僢僼傽偺僨乕僞偑曐懚偝傟偰偄傞昁梫偑偁傝傑偡丅
  枹曐懚帪偵幚峴偡傞偲乽僼傽僀儖偵曐懚偡傞丠乿偲栤偄偐偗傑偡丅偙偙偱 "偄
  偄偊" 傪慖戰偡傞偲幚峴偝傟傑偣傫丅偨偩偟丆[慖戰斖埻傑偨偼1峴幚峴]傪巊
  梡偡傞偲丆枹曐懚偺忬懺偱傕幚峴偡傞偙偲偑偱偒傑偡丅

丒側偱偟偙僄僨傿僞偱奐偄偰曇廤偡傞応崌偼丆[攔懠惂屼] 傪 "偟側偄" 偐 
  "曇廤偟偰傞偲偒偩偗" 偵偟偰偍偐側偄偲懯栚偱偡丅

丒暥帤楍偺嬫愗傝暥帤偲偟偰乽乿傗亀亁傪巊偆偲丆\ 偵傛傞僄僗働乕僾偑岠偒傑
  偣傫丅偦傫側応崌偼丆 "" 偐 `` 傪巊偭偰偔偩偝偄丅

丒僀儞僨儞僩側傫偰傓偮偐偟偄偙偲偼偱偒傑偣傫丅RET(newline) 偲 
  LFD(newline-and-indent) 偑擖傟懼偊偰偁傞偩偗偱偡丅


仭峏怴棜楌:

  [Version 1.04] 2007-12-31 (寧)
  丒MIT儔僀僙儞僗偵偟偨丅
  丒怓晅偗帪偵丆彆帉傛傝愭偵梊栺岅傪儅僢僠偝偣傞傛偆偵偟偨丅

  [Version 1.03] 偄偮丠
  丒敿妏僗儁乕僗傪娷傓僷僗偺張棟偑晄枴偐偭偨偺傪廋惓偟偨丅
  丒懚嵼偟側偄懳榖幃幚峴傪嶍彍偟偨丅

  [Version 1.02]
  丒require 偟偰巊偆傛偆偵偟偨丅
  丒娭悢柤傪偄傠偄傠偲曄峏偟偨丅
  丒敿妏僗儁乕僗 4 偮偱僀儞僨儞僩偡傞傛偆偵偟偨丅
  丒TAB 僉乕偱僀儞僨儞僩偱偒傞傛偆偵偟偨丅

  [Version 1.01] 2005-03-03 (Thu)
  丒僞僽偱僀儞僨儞僩偡傞傛偆偵偟偨丅
  丒shift-selection, unshift-selection 傪偦傟偧傟 M-i, M-u 偵僶僀儞僪偟偨丅

  [Version 1.00] 2005-03-01 (Tue)
  丒偮偔偭偨丅


仭儔僀僙儞僗

  nadesiko-mode.l 偼MIT儔僀僙儞僗偵婎偯偄偰棙梡壜擻偱偡丅
  <http://www.opensource.org/licenses/mit-license.php>

Copyright (c) 2007 HIE Masahiro

Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.

|#

(provide "nadesiko-mode")

(defconstant *nadesiko-mode-version* "1.03")

;;; 劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅 ;;;
;;;  仭 曄悢愝掕乮揔摉偵僇僗僞儅僀僘偡傞偁偨傝乯
;;; 劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅 ;;;

;;; 僀儞僗僩乕儖僷僗
(defvar *nadesiko-path* "C:/usr/local/nadesiko/")

;;; 幚峴僼傽僀儖柤
(defvar *nadesiko-execute-file* "vnako.exe")

;;; 側偱偟偙 Web Site
(defvar *nadesiko-home-url* "http://nadesi.com/")

;;; 惓婯昞尰怓晅偗梡昞帵怓
(defvar *nadesiko-comment-color* '(:keyword :comment)) ; 僐儊儞僩
(defvar *nadesiko-syntax-keyword-color* '(:color 12 0))	; 峔暥僉乕儚乕僪
(defvar *nadesiko-reserve-word-color* '(:color 12 0)) ; 梊栺岅
(defvar *nadesiko-josi-color* '(:color 9 0)) ; 彆帉
(defvar *nadesiko-brackets-color* '(:keyword :string)) ; 妵屖乮暥帤楍乯
(defvar *nadesiko-integer-color* '(:color 12 0)) ; 悢抣
(defvar *nadesiko-label-color* '(:color 5 0)) ; 儔儀儖
(defvar *nadesiko-operator-color* '(:color 4 0)) ; 墘嶼巕
(defvar *nadesiko-punc-color* '(:color 14 0)) ; 嬪撉揰
(defvar *nadesiko-misc-color* '(:color 14 0)) ; 偄傠偄傠

;;; 僀儞僨儞僩寘悢
(defvar *nadesiko-indent-columns* 4)

;;; 僞僽偱僀儞僨儞僩
(defvar *nadesiko-indent-tabs-mode* nil)

(defvar *nadesiko-menu-name*  "側偱偟偙(&N)")


;;; 劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅 ;;;
;;;  仭 偦偺懠偺曄悢愝掕
;;; 劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅 ;;;

(defvar *nadesiko-app-menu* nil)
(defvar *nadesiko-command-menu* nil)
(defvar *nadesiko-mode-hook* nil)
(defvar *nadesiko-regexp-keyword-list* nil)

(defvar *nadesiko-mode-map* nil)
(unless *nadesiko-mode-map*
  (setq *nadesiko-mode-map* (make-sparse-keymap))
  (define-key *nadesiko-mode-map* #\RET 'newline-and-indent)
  (define-key *nadesiko-mode-map* #\LFD 'newline)
  (define-key *nadesiko-mode-map* #\TAB 'nadesiko-indent-line)
  (define-key *nadesiko-mode-map* '(#\C-c #\e) 'nadesiko-editor)
  (define-key *nadesiko-mode-map* '(#\C-c #\x) 'nadesiko-file-execute)
  (define-key *nadesiko-mode-map* '(#\C-c #\p) 'nadesiko-command-menu)
  (define-key *nadesiko-mode-map* '(#\C-c #\C-x) 'nadesiko-execute-partly)
  (define-key *nadesiko-mode-map* '(#\C-c #\?) 'nadesiko-version))

(defvar *nadesiko-mode-syntax-table* nil)
(unless *nadesiko-mode-syntax-table*
  (setq *nadesiko-mode-syntax-table* (make-syntax-table))
  (set-syntax-match *nadesiko-mode-syntax-table* #\( #\))
  (set-syntax-match *nadesiko-mode-syntax-table* #\( #\))
  (set-syntax-escape *nadesiko-mode-syntax-table* #\\)
  (set-syntax-string *nadesiko-mode-syntax-table* #\")
  (set-syntax-string *nadesiko-mode-syntax-table* #\`)
  (set-syntax-start-comment *nadesiko-mode-syntax-table* #\#)
  (set-syntax-end-comment *nadesiko-mode-syntax-table* #\LFD nil t)
  (set-syntax-start-multi-comment *nadesiko-mode-syntax-table* "/*")
  (set-syntax-end-multi-comment *nadesiko-mode-syntax-table* "*/")
  )

(setq *nadesiko-regexp-keyword-list*
      (compile-regexp-keyword-list
       `(
	 ;;僐儊儞僩
	 ("\\(仸\\|乫\\|'\\|//\\|仈\\).*" t ((0 . ,*nadesiko-comment-color*)))
	 ;;峔暥僉乕儚乕僪
	 ("\\(堘偊偽\\|孞傝曉偡\\|孞傝曉偟\\|栠傞\\|敳偗傞\\|懕偗傞\\|廔傢傞\\|廔傢傝\\)"
	  t ((1 . ,*nadesiko-syntax-keyword-color*)))
	 ;;梊栺岅
	 (,(concat "\\(昞帵\\|尵\\|戙擖\\|偼偄\\|偄偄偊\\|偙偙傑偱\\|僉儍儞僙儖\\|僆儞\\|僆僼"
		   "\\|偦傟\\|僫僨僔僐\\|暥帤楍\\|悢抣\\|惍悢\\|幚悢\\|曄悢\\|攝楍\\|幚悢"
		   "\\|僴僢僔儏\\|僌儖乕僾\\|曄悢愰尵\\|昁梫\\|晄梫\\|傕偟\\|側傜\\|側傜偽"
		   "\\|堘\\|娫\\|斀暅\\|孞\\|僄儔乕\\|娔帇\\|忦審暘婒\\|儖乕僾"
		   "\\|敳\\|栠\\|偍傢傝\\|偍傢傞\\)")
	  t ((0 . ,*nadesiko-reserve-word-color*)))
	 ;;彆帉
	 (,(concat "\\(偱側偗傟偽\\|偵偮偄偰\\|側傜偽\\|偲偟偰\\|偔傜偄\\|側偺偐\\|傑偱傪"
		   "\\|側傜\\|傛傝\\|偐傜\\|傑偱\\|傎偳\\|偟偰\\|偩偗\\|側偳\\|偲偼\\|偭偰"
		   "\\|偱\\|傪\\|偺\\|偑\\|偵\\|傊\\|偲\\|偼\\|偰\\)")
	  t ((0 . ,*nadesiko-josi-color*)))
	 ("\\(?:\\([0-9侽-俋]+\\)\\(夞\\)\\|[})乯]\\(夞\\)\\)"
	  t ((1 . ,*nadesiko-integer-color*) (2 . ,*nadesiko-reserve-word-color*)
	     (3 . ,*nadesiko-reserve-word-color*)))
	 ;;儔儀儖
	 ("^[仏仠仭].*" t ((0 . ,*nadesiko-label-color*)))
	 ;;嬪撉揰
	 ("[][丄丆丅;]" t ((0 . ,*nadesiko-punc-color*)))
	 ;;偄傠偄傠
	 ("[][()乮乯#仈\\亸@仐両乣仼仺]" t ((0 . ,*nadesiko-misc-color*)))
	 ;;墘嶼巕
	 ("[亄亅亊亐乛亝亞亗亙亜亾丱!|&仌=亖]" t ((0 . ,*nadesiko-operator-color*)))
	 ("\\([ 丂0-9侽-俋]+\\)\\([<>*/+^-]\\)\\([ 丂0-9侽-俋]+\\)" t
	  ((1 . ,*nadesiko-integer-color*) (2 . ,*nadesiko-operator-color*) (3 . ,*nadesiko-integer-color*)))
	 ;;妵屖乮暥帤楍偺嬫愗傝暥帤乯
	 ("\\(乽[^乿]*乿\\|亀[^亁]*亁\\)" t ((0 . ,*nadesiko-brackets-color*)))
	 ;;悢抣
	 ;("[^a-zA-Z]+\\([0-9]+\\)[^a-zA-Z]+" t ((1 . ,*nadesiko-integer-color*)))
	 ("[0-9侽-俋]+" t ((0 . ,*nadesiko-integer-color*)))
	 )))


;;; 劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅 ;;;
;;;  仭 側偱偟偙儌乕僪
;;; 劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅 ;;;

(defun nadesiko-mode ()
  (interactive)
  (kill-all-local-variables)
  (setq buffer-mode 'nadesiko-mode)
  (setq mode-name "Nadesiko")
  (use-keymap *nadesiko-mode-map*)
  (use-syntax-table *nadesiko-mode-syntax-table*)
  (make-local-variable 'regexp-keyword-list)
  (setq regexp-keyword-list *nadesiko-regexp-keyword-list*)
  (make-local-variable 'indent-tabs-mode)
  (setq indent-tabs-mode *nadesiko-indent-tabs-mode*)
  (nadesiko-menu-update)
  (run-hooks '*nadesiko-mode-hook*))

;;; 側偱偟偙僄僨傿僞偱奐偔
(defun nadesiko-editor (&optional file)
  (interactive)
  (when (or (not (buffer-modified-p))
	    (and (yes-or-no-p "僼傽僀儖傪曐懚偟傑偡傛丅")
		 (save-buffer)))
    (call-process (concat (merge-pathnames "nakopad.exe" *nadesiko-path*) " \""
			  (map-slash-to-backslash (or file (get-buffer-file-name))) "\""))))

;;; 側偱偟偙僼傽僀儖幚峴
(defun nadesiko-file-execute (&optional file wait)
  (interactive)
  (if (or file
	  (not (buffer-modified-p))
	  (and (yes-or-no-p "僼傽僀儖傪曐懚偟傑偡傛丅")
	       (save-buffer)))
      (call-process (concat (merge-pathnames *nadesiko-execute-file* *nadesiko-path*) " \""
			    (map-slash-to-backslash (or file (get-buffer-file-name))) "\"")
		    :wait wait)
    (message "幚峴傪拞巭偟偨丅")))

;;; 側偱偟偙幚峴
(defun nadesiko-execute (data &optional file)
  (interactive "s側偱偟偙柦椷: ")
  (let ((f (make-temp-file-name "_" "nako" "~/")))
    (with-open-file (s f
		       :direction :output
		       :if-exists :overwrite
		       :if-does-not-exist :create)
      (format s "~A~%" data))
    (when (file-exist-p f)
      (nadesiko-file-execute f t)
      (sit-for 1)
      (delete-file f))))

;;; 偵偮偄偰
(defun nadesiko-about ()
  (interactive)
  (message "側偱偟偙儌乕僪 for xyzzy version ~A" *nadesiko-mode-version*)
  (nadesiko-file-execute (merge-pathnames "tools/about.nako" *nadesiko-path*)))

;;; 側偱偟偙晹暘幚峴
(defun nadesiko-execute-partly ()
  (interactive)
  (let (s e code)
    (if (pre-selection-p)
	(selection-start-end (start end)
	  (setf s start
		e end))
      (save-excursion
	(setf s (progn (goto-bol) (point))
	      e (progn (goto-eol) (point)))))
    (reverse-region s e t)
    (next-line)
    (setf code (buffer-substring s e))
    (nadesiko-execute code)))

;;; 儅僯儏傾儖昞帵
(defun nadesiko-manual ()
  (interactive)
  (shell-execute (merge-pathnames "index.htm" (merge-pathnames "doc" *nadesiko-path*))))

;;; 儂乕儉儁乕僕昞帵
(defun nadesiko-home ()
  (interactive)
  (shell-execute *nadesiko-home-url* t))

;;; 僀儞僠僉僀儞僨儞僩
(defun nadesiko-indent-line (&optional arg)
  (interactive "p")
  (if (pre-selection-p)
      (if arg
	  (unshift-selection *nadesiko-indent-columns*)
	(shift-selection *nadesiko-indent-columns*))
    (let ((p (bolp))
	  (x (if arg -1 1)))
      (save-excursion
	(shift-region (progn (goto-bol) (point))
		      (progn (goto-eol) (point))
		      (* x *nadesiko-indent-columns*)))
      (when p (back-to-indentation)))))


;;; 劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅 ;;;
;;;  仭 側偱偟偙僐儅儞僪儊僯儏乕
;;; 劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅 ;;;

;;; 僐儅儞僪儊僯儏乕昞帵
(defun nadesiko-command-menu ()
  (interactive)
  (unless *nadesiko-command-menu*
    (nadesiko-create-popup-menu))
  (track-popup-menu *nadesiko-command-menu*))

;;; command.txt 偐傜億僢僾傾僢僾儊僯儏乕傪嶌惉
(defun nadesiko-create-popup-menu ()
  (long-operation
    (let ((b (get-buffer-create "*nadesiko-cmd*")))
      (set-buffer b)
      (insert-file-contents
       (merge-pathnames "command.txt" (merge-pathnames "tools" *nadesiko-path*)))
      (goto-char (point-min))
      (let ((menu (create-popup-menu)) m1 m2)
	(while (not (eobp))
	  (message "側偱偟偙儊僯儏乕嶌惉拞 ... ~D" (current-line-number))
	  (when (looking-at "^+")
	    (setf m1 (create-popup-menu))
	    (add-popup-menu menu m1
			    (buffer-substring (progn (forward-char 1) (point))
					      (progn (goto-eol) (point)))))
	  (when (looking-at "^-")
	    (setf m2 (create-popup-menu))
	    (add-popup-menu m1 m2
			    (buffer-substring (progn (forward-char 1) (point))
					      (progn (goto-eol) (point)))))
	  (when (looking-at "^|")
	    (let ((c (buffer-substring (progn (forward-char 1) (point))
				       (progn (scan-buffer ",\"") (point))))
		  (s (buffer-substring (progn (scan-buffer "\",\"" :no-dup t :tail t) (point))
				       (progn (scan-buffer "\",") (point)))))
	      (add-menu-item m2 nil (concat c "	" s)
			     #'(lambda () (interactive) (insert c)))))
	  (next-line)
	  (goto-bol))
	(delete-buffer b)
	(setf *nadesiko-command-menu* menu)))))


;;; 劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅 ;;;
;;;  仭 側偱偟偙傾僾儕儊僯儏乕
;;; 劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅劅 ;;;

(defun nadesiko-menu-update ()
  (interactive)
  (use-local-menu (nadesiko-add-menu)))

(defun nadesiko-add-menu ()
  (let ((menu (copy-menu-items *app-menu* (create-menu))))
    (insert-popup-menu menu (get-menu-position menu 'ed::help)
                       *nadesiko-app-menu*
                       *nadesiko-menu-name*)
    menu))

(add-hook
 '*init-app-menus-hook*
 #'(lambda ()
     (unless *nadesiko-app-menu*
       (setq *nadesiko-app-menu*
	     (let ((menu (create-popup-menu)))
	       (add-menu-item menu nil "側偱偟偙僄僨傿僞偱奐偔(&E)" 'nadesiko-editor)
	       (add-menu-item menu nil "側偱偟偙僐儅儞僪儊僯儏乕(&P)" 'nadesiko-command-menu)
	       (add-menu-separator menu)
	       (add-menu-item menu nil "幚峴(&X)" 'nadesiko-file-execute)
	       (add-menu-item menu nil "慖戰斖埻傑偨偼1峴偩偗幚峴(&L)" 'nadesiko-execute-partly)
	       (add-menu-separator menu)
	       (add-popup-menu menu
			       (define-popup-menu
				 (:item nil "昗弨GUI - vnako.exe(&G)"
				  #'(lambda () (interactive) (nadesiko-toggle-execute-file "vnako.exe"))
				  #'(lambda () (when (equal *nadesiko-execute-file* "vnako.exe") :check)))
				 (:item nil "娙堈GUI - gnako.exe(&U)"
				  #'(lambda () (interactive) (nadesiko-toggle-execute-file "gnako.exe"))
				  #'(lambda () (when (equal *nadesiko-execute-file* "gnako.exe") :check)))
				 (:item nil "僐儞僜乕儖 - cnako.exe(&C)"
				  #'(lambda () (interactive) (nadesiko-toggle-execute-file "cnako.exe"))
				  #'(lambda () (when (equal *nadesiko-execute-file* "cnako.exe") :check)))
				 ) "側偱偟偙幚峴曽幃(&Y)")

	  (add-menu-separator menu)
	  (add-menu-item menu nil "儅僯儏傾儖(&H)" 'nadesiko-manual)
	  (add-menu-item menu nil "側偱偟偙偺儁乕僕(&H)" 'nadesiko-home)
	  (add-menu-item menu nil "偵偮偄偰(&A)..."  'nadesiko-about)
	  menu)))))

(defun nadesiko-toggle-execute-file (&optional file)
  (interactive)
  (setf *nadesiko-execute-file*
	(or file (cond ((equal *nadesiko-execute-file* "vnako.exe") "gnako.exe")
		       ((equal *nadesiko-execute-file* "gnako.exe") "cnako.exe")
		       (t "vnako.exe")))))


;;; nadesiko-mode.l 偼丆偙偙傑偱丅
