#| habuki-make-rule lapse001 for xyzzy-0.2.2.235 or over version

 Copyright (C) 2007-2008 knenet
 All rights reserved.
 <kneneglect_std@yahoo.co.jp>

漢直「小ノ目（はぶき）」規則の作成を支援する。

このプログラムは以下の１つのファイルで構成される。

habuki-make-rule.l

 説明

ウィザードはないので、簡単に手順を書いておく。
LISPの割に手順通りに進めないといけないのはご愛敬。

 使い方

habuki-make-rule.lをバイトコンパイルし、生成された
habuki-make-rule.lcをsite-lisp下に置く。

*scratch*などのlisp-interaction-modeのバッファで、
(load-library "habuki-make-rule")を評価する。
評価するとuser領域に関数を垂れ流すので留意すること。

文字の頻度表を用意する。ここでは、kouの「もんじ」による
頻度表の作成方法を説明する。
適当なファイルに、好きな文章を詰め込む。これから自分が
打つような文章が望ましい。目標は100万字である。
もし、出来るだけ多くの文字を登録したいなら、
habuki-kanji.rlも含めると良い。
今何文字かは、xyzzy上で、バッファの一番最後でC-x =を入力
すれば表示できる。
半角文字は要らないので全部消す。英字、数字、ギリシャ字、
ロシア字、各種記号のうち、不要なものも全て消す。
頻度表を作成してから消しても良いが、置換で消すと楽だと思う。
テキストをもんじで読み込む。
必要な字だけを表示させ、文字と出現回数を別々のファイルで
書き出す。スペース区切りがいいと思う。
文字はスペースをなくして、(setq charseq "あいうえお")
のようにcharsに文字列として定義する。
出現回数は(setq orderseq '(100 50 20 10 5))のように
orderseqにリストとして定義する。

いくつのキーを用いるか定義する。
(setq N キー数)でNを定義する。
デフォルトでは36となっている。

スロットをいくつ用意するか定義する。
頻度表の文字種以上であるのは最低条件だが、
空きスロットがない＝3打鍵字で打ちにくいパターンがある
ということもあるので、多めにしておいた方が良い気がする。
あまり多すぎると登録できなくなる。5000前後がよい。
(def-K t スロット数)とすると、K値が決まる。
K値は3打鍵の盤面の最低数である。
実際のスロット数は、K値によって定まる。

1打鍵字をいくつにするか検討する。
(exam-1 t)を評価すると、
1打鍵字の可能な取り方の一覧が出る。
PCのスペックによっては時間がかかるかも知れない。
このうち、平均打鍵数が一番少ないものを選ぶ。
2打鍵字が少ないなど、気に入らなければ他のものでもよい。

1打鍵字の数を決めたら、キーごとの打鍵頻度表が出来る。
(def-duty t 1打鍵字の数)とすると、dutyに頻度が定義される。
また、規則の作成に必要な変数を色々定義する。
PCのスペックによっては時間がかかる。
この頻度の順番をキー順位と呼ぶ。
これを元にキー順位と実際のキーとの対応を決める。

キー順位0〜(N-1)までを、それぞれの指に割り振る。
ここはあまり自動化できなかったので大変。
まず、(summon-tool t)を評価すると関数群が現れる。
説明も表示されるので、指とキー順位の対応を決める。
割といい加減だが、最終的にkey-orderという変数が、
'((0 . #\a) (1 . #\b) (3 . #\c))
のような順位とキーのconsのlistになっていればよい。

key-orderができ上がれば、規則をファイルに書き出せる。
(output-rule-file "my.rl")のように評価する。
PCのスペックによってはかなり時間がかかる。
漢字と規則が対応したファイルが作成される。
空きスロットは、新たに字を追加したいときに必要となる
ので、別のファイルに分けて保存しておく。
これで規則は完成である。
交互打鍵率は考慮していないので、
大体5割程度になると思われる。
規則の評価は、habuki-modeにhabuki-test-rule-region
を用意したので、それで行ってもらいたい。
regionの文字列（未登録字を除く）をどんな風に打てるか
をヘルプに表示してくれる。

まとめ（例）
(load-library "habuki-make-rule")
(setq charseq "あいうえお")
(setq orderseq '(100 50 20 10 5))
(def-K t 5000)
(exam-1 t)
(def-duty t 20)
(summon-tool t)
(output-rule "my.rl")

なお、規則ファイルにバージョンや作成者を
記載したい場合、行頭に%を付けるとコメントになる。

値が全て決まったら、１つのファイルにまとめておくと
eval-bufferで規則を作成できる。
（イメージ）
(setq N 〜
      charseq 〜
      orderseq 〜)
(def-K nil 〜)
(def-duty nil 〜)
(def-key-order nil 〜)
(output-rule 〜)

 履歴

 lapse001 2008-03-12 03:34 公開。実装がかなり強引で分かりづらいニ＿ニ；

 権利・責任関係
日本国の著作権法が適用される範囲でknenetが著作権を持つ。
細かく見ると、どこにも主張するべき点がなさそうだけれども。
ライセンスは以下の通り。MIT Licenseと同等であると考えて良い。

配布、改造、編纂等の再利用を許可する。二次創作物の権利は一切主張しない（し得ない）。
ただし、ファイルのバージョンや作成・配布元が区別できるように名前や表示を考慮すること。
後に情報元がたどれるように、著作権表示を明記すること。
何人も、このプログラムによって生じた損益について責任を持たない。
このプログラムを使用する者は、同時にこのライセンスを許諾しているものとみなす。

えんいー |#

;●●variables●●

(setq charseq "あいうえお")
(setq orderseq '(100 50 20 10 5))
(setq N 36)

(setq K nil
      rule nil
      duty nil
      denom nil
      all-char nil
      all-stroke nil
      A nil
      B nil
      C nil
      E nil)

;●●main functions●●

(defun def-K (fp slot)
  (if (numberp N)
    (let* ((k (/ (- slot (* N N)) (1- N)))
	   (? (< k (* N N))))
      (format fp "~Aスロット確保~A~A~A"
	      slot (if ? "すると、3打鍵字始動キーは" "は無理だ。スロット数は")
	      (if ? (setq K (ceiling k)) (* N N N))
	      (if ? "個+1打鍵字の数になる。" "個が最大だ。ギリギリでも良くないけど。")))
    (format fp "落ち着け、キー数Nがおかしいぜ。")))

(defun exam-1 (fp)
  (format fp "確保されたスロット数~A~%1打  2打  3打 ％ 1打   2打   3打 平均打鍵数~%"
	  (+ (* N N) (* (1- N) K)))
  (unless all-char (all-char))
  (defun exam-sub (p)
    (let ((q (- (* (- N p) N) K p))
	  (r (* (+ K p) N)))
      (when (and (< p N)
		 (< 0 q))
	(let ((pt (apply '+ (subseq orderseq 0 p)))
	      (qt (apply '+ (subseq orderseq p (+ p q))))
	      (rt (apply '+ (subseq orderseq (+ p q)))))
	  (format fp "~3D ~4D ~4D  ~5F ~5F ~5F   ~5F~%"
		  p q r
		  (/ pt (+ pt qt rt) 0.01)
		  (/ qt (+ pt qt rt) 0.01)
		  (/ rt (+ pt qt rt) 0.01)
		  (/  (+ pt (* 2 qt) (* 3 rt)) all-char)))
	(exam-sub (1+ p)))))
  (exam-sub 0))

(defun def-duty (fp single-stroke-char-number)
  (long-operation
    (setq A single-stroke-char-number
	  B (- N A)
	  E (+ K A)
	  C (- (* B N) E))
      (message "~A" A)
      (setq all-stroke (let ((sum 0)
			     (C (- (* (- N A) N) (+ K A))))
			 (dolist (x (subseq orderseq 0 A)) (setq sum (+ sum x)))
			 (dolist (x (subseq orderseq A (+ A C))) (setq sum (+ sum (* 2 x))))
			 (dolist (x (subseq orderseq (+ A C))) (setq sum (+ sum (* 3 x))))
			 (/ sum 1.0)))
      (format fp "~3D:" A)
      (dolist (o (setq duty (map 'list #'(lambda (x) (/ x all-stroke 0.01)) (map 'list '+ (dutyF) (dutyC+E) (dutyA+B)))))
	(format fp " ~5F" o))
      (format fp "~%")))

(defun summon-tool (fp)
  (format fp (concat ";各リストを指だと考えて、キー順位を入れる。~%"
		     ";duty-of-fingerを評価すると、指ごとの負荷率が出るので、~%"
		     ";順位を入れ替えて調整する。~%"
		     ";調整が終わったら、関数をdef-key-orderに変えて評価する。~%"
		     "(duty-of-finger t~%"
		     "'((0          33 35) \"wqs\"    左小指~%"
		     "  (1          32 34) \"@[:\"    右小指~%"
		     "  (2    15 20 31)    \"e3d2\"   左薬指~%"
		     "  (3    14 21 30)    \"p-;^\"   右薬指~%"
		     "  (4    13 17 22 29) \"r5f46\"  左中指~%"
		     "  (5    12 16 23 28) \"o9l08\"  右中指~%"
		     "  (6  8 11 18 24 27) \"gthbvy\" 左人差指~%"
		     "  (7  9 10 19 25 26) \"kijm,u\" 右人差指))~%"
		     ";左小 | 右小 | 左薬 | 右薬 | 左中 | 右中 | 左人 | 右人 |~%")))

(defun duty-of-finger (fp ls)
  (dolist (b ls)
    (when (listp b)
      (format fp " ~4F  " (apply '_^ b))))
  (format fp "~%"))

(defun def-key-order (fp ls)
  (format fp "~A~%できた。揃ってるか確認してないので気を付けてね（←手抜き）。"
	  (setq key-order
		(stable-sort
		 (map 'list 'cons
		      (apply 'append (remove-if-not 'listp ls))
		      (apply 'concat (remove-if-not 'stringp ls)))
		 '< :key 'car))))

(defun output-rule-file (file)
  (when (= (length key-order) N)
    (long-operation
      (let (seq1
	    (seq2 (comb B N))
	    (seq3 (comb E N)))
	(dotimes (x N) (push (- N x 1) seq1))
	(let* ((prefix1 (distribute seq1 (orderA+B) 'B))
	       (prefix2 (map 'list #'(lambda (x)
				       (list (elt prefix1 (car x)) (cdr x)))
			     (distribute seq2 (orderC+E) 'E))))
	  (defun rule ()
	    (append
	     (map 'list 'list (distribute seq1 (orderA+B) 'A))
	     (map 'list #'(lambda (x)
			    (list (elt prefix1 (car x)) (cdr x)))
		  (distribute seq2 (orderC+E) 'C))
	     (map 'list #'(lambda (x)
			    (append (elt prefix2 (car x)) (list (cdr x))))
		  seq3)))

	  (defun output-prefix (fp)
	    (dolist (x prefix1)
	      (format fp "~A>#p~%" (cdr (assoc x key-order))))
	    (dolist (x prefix2)
	      (format fp "~A~A>#p~%"
		      (cdr (assoc (first x) key-order))
		      (cdr (assoc (second x) key-order)))))

	  (defun output-rule (fp)
	    (let ((rule (rule))
		  (drain (length charseq)))
	      (dotimes (x (+ (* N N) (* K (- N 1))))
		(dolist (c (elt rule x))
		  (format fp "~A" (cdr (assoc c key-order))))
		(format fp ">~A~%" (if (< x drain) (elt charseq x) "")))))
	  (with-open-file (to file :direction :output
			      :if-exists :append :if-does-not-exist :create)
	    (output-prefix to)
	    (output-rule to)))))))

;●●sub functions●●

(defun all-char ()
  (setq all-char (let ((s 0)) (dolist (x orderseq s) (setq s (+ s x))))))

(defun adorn (l type) (map 'list #'(lambda (x) (cons x type)) l))

(defun comb (X Y)
  (let (l)
    (defun sub (x y)
      (when (and (< y Y) (<= 0 x))
	(sub (1- x) (1+ y)) (push (cons x y) l)))
    (dotimes (c (+ X Y) (reverse l))
      (sub (if (< c (1- X)) c (1- X))
	   (if (< c (1- X)) 0 (- c (1- X)))))))

(defun dutyF ()
  (let (duty) (dotimes (x N) (push 0 duty))
    (map nil #'(lambda (x c) (setf (elt duty x) (+ (elt duty x) c)))
	 (map 'list 'cdr (comb E N))
	 (subseq orderseq (+ A C)))
    duty))

(defun freqE ()
  (let (freq) (dotimes (x E) (push 0 freq))
    (map nil #'(lambda (x c) (setf (elt freq x) (+ (elt freq x) c)))
	 (map 'list 'car (comb E N))
	 (subseq orderseq (+ A C)))
    (map 'list #'(lambda (x) (cons x 'E)) freq)))

(defun freqB ()
  (let (freq) (dotimes (x B) (push 0 freq))
    (map nil #'(lambda (x c) (setf (elt freq x) (+ (elt freq x) c)))
	 (map 'list 'car (comb B N))
	 (map 'list 'car (orderC+E)))
    (adorn freq 'B)))

(defun dutyA+B () (map 'list 'car (orderA+B)))

(defun dutyC+E ()
  (let (duty) (dotimes (x N) (push 0 duty))
    (map nil #'(lambda (x c) (setf (elt duty x) (+ (elt duty x) c)))
	 (map 'list 'cdr (comb B N))
	 (map 'list 'car (orderC+E)))
    duty))

(defun orderC+E () (stable-sort (append (adorn (subseq orderseq A (+ A C)) 'C) (freqE)) #'> :key 'car))

(defun orderA+B () (stable-sort (append (adorn (subseq orderseq 0 A) 'A) (freqB)) #'> :key 'car))

(defun _^ (&rest s) (apply '+ (map 'list #'(lambda (x) (elt duty x)) s)))


(defun distribute (seq comp type)
  (map 'list #'car (remove-if-not #'(lambda (x) (eq x type))
				  (map 'list 'cons seq (map 'list 'cdr comp)) :key 'cdr)))
