(defvar 1B-list '["!" "\"" "#" "$" "%" "&" "'" "(" ")" "*" "+" "," "-" "." "/" "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" ":" ";" "<" "=" ">" "?" "@" "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z" "[" "\\" "]" "^" "`" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o" "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z" "{" "|" "}" "~"])
(defvar 2B-list '["！" "”" "＃" "＄" "％" "＆" "’" "（" "）" "＊" "＋" "，" "−" "．" "／" "０" "１" "２" "３" "４" "５" "６" "７" "８" "９" "：" "；" "＜" "＝" "＞" "？" "＠" "Ａ" "Ｂ" "Ｃ" "Ｄ" "Ｅ" "Ｆ" "Ｇ" "Ｈ" "Ｉ" "Ｊ" "Ｋ" "Ｌ" "Ｍ" "Ｎ" "Ｏ" "Ｐ" "Ｑ" "Ｒ" "Ｓ" "Ｔ" "Ｕ" "Ｖ" "Ｗ" "Ｘ" "Ｙ" "Ｚ" "［" "￥" "］" "＾" "｀" "ａ" "ｂ" "ｃ" "ｄ" "ｅ" "ｆ" "ｇ" "ｈ" "ｉ" "ｊ" "ｋ" "ｌ" "ｍ" "ｎ" "ｏ" "ｐ" "ｑ" "ｒ" "ｓ" "ｔ" "ｕ" "ｖ" "ｗ" "ｘ" "ｙ" "ｚ" "｛" "｜" "｝" "〜"])

(defvar start-mark-list '(("｛".lc-jef) ( "＜".lc-jp2)))
(defvar end-mark-list '("｝" "＞"))
(defvar search-string-list '("\\cF" "\\cP"))
(defconst GETA "■")

(defun ext-code-string-to-char ()
 "拡張文字コード文字列を拡張文字に変換する。"
 (interactive)
 (save-excursion
   (setq mark-length (length start-mark-list))
   (while (> mark-length 0)
     (let ((start-mark (car (nth (1- mark-length) start-mark-list)))
	   (end-mark (nth (1- mark-length) end-mark-list))
	   (lc-ext (eval (cdr (nth (1- mark-length) start-mark-list))))
	   (mark-start (make-marker))
	   (mark-end (make-marker)))
       (goto-char (point-min))
       (while (not (eobp))
	 (if (search-forward end-mark nil t)
	     (progn
	       (setq mark-end (point))
	       (if (search-backward start-mark nil t)
		   (progn
		     (setq mark-start (point))
		     (if (re-search-forward "[０-９Ａ-Ｆａ-ｆ]\n*[０-９Ａ-Ｆａ-ｆ]\n*[０-９Ａ-Ｆａ-ｆ]\n*[０-９Ａ-Ｆａ-ｆ]" mark-end t)
			 (progn
			   (setq 2B-code-string (buffer-substring (match-beginning 0)(match-end 0)))
			   (if (search-backward "\n" mark-start t)
			       (setq add-newline t)
			     (setq add-newline nil))
			   (delete-region mark-start mark-end)
			   (setq 1B-code-string (2B-to-1B 2B-code-string))
			   (setq ext-high (hex-string-to-int (substring 1B-code-string 0 2)))
			   (if (> ext-high 127) (setq ext-high (- ext-high 96)))
			   (setq ext-low (hex-string-to-int (substring 1B-code-string 2)))
			   (insert (make-character lc-ext ext-high ext-low))
			   (if add-newline (insert "\n")))
		       (goto-char mark-end)))
		 (error "unbalanced extent character code string")))
	   (goto-char (point-max)))))
     (setq mark-length (1- mark-length)))
   (message "Done.")))

(defun ext-char-to-code-string ()
  "拡張文字を拡張文字コード文字列に変換する"
  (interactive)
  (save-excursion
    (setq mark-length (length start-mark-list))
    (while (> mark-length 0)
      (let* ((start-mark (car (nth (1- mark-length) start-mark-list)))
	     (end-mark (nth (1- mark-length) end-mark-list))
	     (search-string (nth (1- mark-length) search-string-list))
	     (lc-ext (eval (cdr (nth (1- mark-length) start-mark-list)))))
	(goto-char (point-min))
	(while (not (eobp))
	  (if (re-search-forward search-string nil t)
	      (progn
		(setq ext-high (- (char-component (char-before (point)) 1) 128))
		(setq ext-low (char-component (char-before (point)) 2))
		(cond ((and (= lc-ext lc-jef) (< ext-high 65))
		       (setq ext-high (+ ext-high 96)))
		      ((= lc-ext lc-jp2)
		       (setq ext-low (- ext-low 128))))
		(setq ext-code-string (format "%s%s" (int-to-hex-string ext-high) (int-to-hex-string ext-low)))
		(delete-char -1)
		(insert (format "%s%s%s" start-mark (1B-to-2B ext-code-string) end-mark)))
	    (goto-char (point-max)))))
      (setq mark-length (1- mark-length)))
    (message "Done.")))

(defun add-ext ()
 "ＳＫＫ辞書内の拡張漢字コード文字列に対応した拡張文字を追加する。"
(interactive)
(save-excursion
  (setq mark-length 1)
  (while (> mark-length 0)
    (let ((start-mark (car (nth (1- mark-length) start-mark-list)))
	  (end-mark (nth (1- mark-length) end-mark-list))
	  (lc-ext (eval (cdr (nth (1- mark-length) start-mark-list)))))
      (goto-char (point-min))
      (while (not (eobp))
	(if (search-forward end-mark nil t)
	    (progn
	      (setq mark-end (point))
	      (beginning-of-line)
	      (setq limit1 (point))
;;	      (end-of-line)
;;	      (setq limit2 (point))
	      (goto-char mark-end)
	      (if (search-backward start-mark limit1 t)
		  (progn
		    (setq mark-start (point))
		    (if (re-search-forward "[０-９Ａ-Ｆａ-ｆ]\n*[０-９Ａ-Ｆａ-ｆ]\n*[０-９Ａ-Ｆａ-ｆ]\n*[０-９Ａ-Ｆａ-ｆ]" mark-end t)
			(progn
			  (setq 2B-code-string (buffer-substring (match-beginning 0)(match-end 0)))
			  (search-forward "/" nil t)
			  (setq 1B-code-string (2B-to-1B 2B-code-string))
			  (setq ext-high (hex-string-to-int (substring 1B-code-string 0 2)))
			  (if (> ext-high 127) (setq ext-high (- ext-high 96)))
			  (setq ext-low (hex-string-to-int (substring 1B-code-string 2)))
			  (insert (make-character lc-ext ext-high ext-low))
			  (insert "/"))
		      (goto-char (1+ mark-end))))))
	  (goto-char (point-max)))))
    (setq mark-length (1- mark-length)))
  (message "Done.")))


(defun int-to-hex-string (int)
  "Convert the integer argument to a C-style hexadecimal string."
  (let ((shiftval -20)
	(str "0x")
	(hex-chars "0123456789ABCDEF"))
    (while (<= shiftval 0)
      (setq str (concat str (char-to-string 
			(aref hex-chars
			      (logand (lsh int shiftval) 15))))
	    shiftval (+ shiftval 4)))
    (string-match "^0x0*" str)
    (setq str (substring str (match-end 0)))
    str))

(defun hex-string-to-int (str)
  ""
  (setq diff 0
	int 0)
  (while (> (length str) 0)
    (setq hex-str (substring str (1- (length str))))
    (cond ((not (string< hex-str "a")) ;; a-f
	   (setq num (- (string-to-char hex-str) 87)))
	  ((not (string< hex-str "A")) ;; A-F
	   (setq num (- (string-to-char hex-str) 55)))
	  ((not (string< hex-str "0")) ;;0-9
	   (setq num (- (string-to-char hex-str) 48)))
	  (t (error "invalid hex code")))
    (setq int (+ int (* num (lsh 1 diff)))
          diff (+ diff 4)
	  str (substring str 0 (1- (length str)))))
  int)

(defun 2B-to-1B (2B-string)
 "２バイトコード文字を１バイトコード文字に変換する"
 (interactive)
 (if (not (boundp '2B-to-1B-assoc)) (make-2B-to-1B-assoc))
 (setq p 0)
 (setq 1B-string "")
 (save-excursion
   (setq temp-buffer (get-buffer-create (concat " " (current-time-string))))
   (set-buffer temp-buffer)
   (insert 2B-string)
   (goto-char (point-min))
   (while (not (eobp))
     (progn
       (setq 1B-string (concat 1B-string (cdr (assoc (buffer-substring (point) (1+ (point))) 2B-to-1B-assoc))))
     (forward-char 1)))
   (kill-buffer temp-buffer)
   1B-string))

(defun 1B-to-2B (1B-string)
 "１バイトコード文字を２バイトコード文字に変換する"
 (interactive)
 (if (not (boundp '1B-to-2B-assoc)) (make-1B-to-2B-assoc))
 (setq p 0)
 (setq 2B-string "")
 (save-excursion
   (setq temp-buffer (get-buffer-create (concat " " (current-time-string))))
   (set-buffer temp-buffer)
   (insert 1B-string)
   (goto-char (point-min))
   (while (not (eobp))
     (progn
       (setq 2B-string (concat 2B-string (cdr (assoc (buffer-substring (point) (1+ (point))) 1B-to-2B-assoc))))
     (forward-char 1)))
   (kill-buffer temp-buffer)
   2B-string))

(defun make-1B-to-2B-assoc ()
 ""
 (setq p 0)
 (setq 1B-to-2B-assoc nil)
 (while (< p (length 1B-list))
   (setq 1B-to-2B-assoc  (append 1B-to-2B-assoc (list (cons (aref 1B-list p) (aref 2B-list p)))))
  (setq p (1+ p)))
 1B-to-2B-assoc)

(defun make-2B-to-1B-assoc ()
 ""
 (setq p 0)
 (setq 2B-to-1B-assoc nil)
 (while (< p (length 2B-list))
   (setq 2B-to-1B-assoc  (append 2B-to-1B-assoc (list (cons (aref 2B-list p) (aref 1B-list p)))))
  (setq p (1+ p)))
 2B-to-1B-assoc)


(defun togeta ()
 "ＪＩＳ補助、ＪＥＦ拡張コード形式の部分を■に置換する。"
 (interactive)
 (save-excursion
   (setq mark-length (length start-mark-list))
   (while (> mark-length 0)
     (let ((start-mark (car (nth (1- mark-length) start-mark-list)))
	   (end-mark (nth (1- mark-length) end-mark-list))
	   (lc-ext (eval (cdr (nth (1- mark-length) start-mark-list))))
	   (mark-start (make-marker))
	   (mark-end (make-marker)))
       (goto-char (point-min)) 
       (while (not (eobp))
	 (if (search-forward end-mark nil t)
	     (progn
	       (setq mark-end (point))
	       (if (search-backward start-mark nil t)
		   (progn
		     (setq mark-start (point))
		     (if (search-backward "\n" mark-start t)
			 (setq add-newline t)
		       (setq add-newline nil))
		     (delete-region mark-start mark-end)
		     (insert "■")
		     (if add-newline (insert "\n"))
		     (goto-char (1- mark-end)))
		 (error "unbalanced extent character code string")))
	   (goto-char (point-max)))))
     (setq mark-length (1- mark-length)))
   (message "Done.")))

(defun collect-ext ()
 "ＪＩＳ補助、ＪＥＦ拡張コード形式の部分を蒐集報告する。"
 (interactive)
 (save-excursion
   (setq mark-length (length start-mark-list))
   (while (> mark-length 0)
     (let ((start-mark (car (nth (1- mark-length) start-mark-list)))
	   (end-mark (nth (1- mark-length) end-mark-list))
	   (lc-ext (eval (cdr (nth (1- mark-length) start-mark-list))))
	   (mark-start (make-marker))
	   (mark-end (make-marker)))
     (goto-char (point-min)) 
       (while (not (eobp))
	 (if (search-forward end-mark nil t)
	     (progn
	       (set-marker mark-end (point))
	       (if (search-backward start-mark nil t)
		   (progn
		     (set-marker mark-start (point))
		     (setq ext-str (buffer-substring mark-start mark-end))
		     (if (string-match "\n" ext-str)
			 (setq ext-str (concat (substring ext-str 0 (match-beginning 0)) (substring ext-str (match-end 0)))))
		     (goto-char (point-min))

		     (insert (format "%s\n" ext-str))
		     (goto-char mark-end))
		 (error "unbalanced extent character code string")))
	   (goto-char (point-max)))))
     (setq mark-length (1- mark-length)))
   (message "Done.")))