Script-Fu

	(define (script-fu-duplicate-layer img layer)
	(let ((copy-layer (car (gimp-layer-copy layer TRUE))))
	(gimp-image-add-layer img copy-layer -1)
	(gimp-displays-flush)))
	(script-fu-register
	"script-fu-duplicate-layer"
	"Duplicate Layer..."
	"description"
	"name"
	"copyright"
	"date"
	"RGB*"
	SF-IMAGE "Image" 0
	SF-DRAWABLE "Drawable" 0)
	(script-fu-menu-register "script-fu-duplicate-layer"
	"<Image>/Filters/Test")

view raw duplicate.scm hosted with ❤ by GitHub

	(define (script-fu-create-new-image bg-color width height)
	(let ((img (car (gimp-image-new width height RGB))))
	(let ((layer (car (gimp-layer-new img width height RGB-IMAGE
	"Background" 100 NORMAL-MODE))))
	(gimp-context-push)
	(gimp-deawable-fill layer BG-IMAGE-FILL)
	(gimp-image-add-layer img layer -1)
	(gimp-context-pop)
	(gimp-display-new img)
	(gimp-displays-flush))))
	(script-fu-register
	"script-fu-create-new-image"
	"New Image..."
	"description"
	"name"
	"copyright"
	"date"
	""
	SF-COLOR "Background color" '(255 255 255)
	SF-ADJUSTMENT "Width" '(256 1 1024 1 10 0 1)
	SF-ADJUSTMENT "Height" '(256 1 1024 1 10 0 1))
	(script-fu-menu-register "script-fu-create-new-image"
	"<Image>/Filters/Test")

view raw create-new-image.scm hosted with ❤ by GitHub

	;; ドロップシャドウを作るスクリプト
	(define (script-fu-drop-shadow-text text size font bg-color text-color)
	(let ((img (car (gimp-image-new 256 256 RGB))))
	;; 前処理
	(gimp-image-undo-disable img)
	(gimp-context-push)
	;; テキストレイヤー作り
	(gimp-context-set-foreground text-color)
	(let ((text-layer (car (gimp-text-fontname img -1 0 0 text 20
	TRUE size PIXELS font))))
	;; 背景レイヤー作り
	(let ((width (car (gimp-drawable-width text-layer)))
	(height (car (gimp-drawable-height text-layer))))
	(gimp-image-resize img width height 0 0)
	(let ((bg-layer (car (gimp-layer-new img width height RGB-IMAGE
	"Background" 100 NORMAL-MODE))))
	(gimp-image-add-layer img bg-layer 1)
	(gimp-context-set-background bg-color)
	(gimp-edit-clear bg-layer)
	;; ドロップシャドウの作成
	(gimp-context0set-foreground '(0 0 0))
	(let ((shadow-layer (car (gimp-text-fontname img -1 0 0 text 20
	TRUE xize PIXELS font))))
	(gimp-channel-ops-offset shadow-layer FALSE OFFSET-TRANSPARENT 5 5)
	(gimp-channel-ops-offset text-layer FALSE OFFSET-TRANSPARENT -5 -5)
	(plug-in-gauss-iir2 1 img shadow-layer 20 20)
	(gimp-layer-set-opacity shadow-layer 75)
	;; 後処理
	(gimp-context-pop)
	(gimp-image-undo-enable img)
	(gimp-display-new img)
	(gimp-displays-flush)))))))
	;; スクリプトの登録
	(script-fu-register
	"script-fu-drop-shadow-text"
	"Drop Shadow Text..."
	"Create the drop shadow text"
	"Iccii <iccii@hotmail.com>"
	"iccii"
	"Jun, 2001/May, 2009"
	""
	SF-STRING "Text" "Script-Fu!"
	SF-ADJUSTMENT "Font size (pixels)" '(100 2 1000 1 10 0 1)
	SF-FONT "Font" "Dragonwick"
	SF-COLOR "Background color" '(255 255 255)
	SF-COLOR "Text color" '(223 8 8))
	(script-fu-menu-register "script-fu-drop-shadow-text"
	"<Image>/Filters/Test")

view raw drop-shadow-text.scm hosted with ❤ by GitHub

	(define (script-fu-all-inputs-box
	image drawable layer channel vectors color
	toggle value string filename dirname
	adjustment0 adjustment1 font pattern brush
	gradient option palette text enum display)
	;; (gimp-message "This is the input box test script!")
	(gimp-message (string-append
	"Image is " (number->string image) "\n"
	"Drawable is " (number->string drawable) "\n"
	"Layer is " (number->string layer) "\n"
	"Channel is " (number->string channel) "\n"
	"Vectors is " (number->string vectors) "\n"
	"Color is " "'(" (number->string (car color)) " "
	(number->string (cadr color)) " "
	(number->string (caddr color)) ")\n"
	"Toggle is " (if (equal? toggle TRUE) "TRUE\n" "FALSE\n")
	"Value is " (number->string value) "\"\n"
	"String is " "\"" string "\"\n"
	"Filename is " "\"" filename "\"\n"
	"Dirname is " "\"" dirname "\"\n"
	"Adjust0 is " (number->string adjustment0) "\n"
	"Adjust1 is " (number->string adjustment1) "\n"
	"Font is " "\"" font "\"\n"
	"Pattern is " "\"" pattern "\"\n"
	"Brush is " "'(" "\"" (list-ref brush 0) "\" "
	(number->string (list-ref brush 1)) " "
	(number->string (list-ref brush 2)) " "
	(number->string (list-ref brush 3)) ")\n"
	"Gradient is " "\"" gradient "\"\n"
	"Option is " (number->string option) "\n"
	"Palette is " "\"" palette "\"\n"
	"Text is " "\"" text "\"\n"
	"Enmu is " (number->string enum) "\n"
	"Display is " (number->string display)))
	)
	(script-fu-register
	"script-fu-all-inputs-box"
	"All Inputs Box..."
	"Show all inputs box"
	"Iccii <iccii@hotmail.com>"
	"Iccii"
	"Jun, 2001/May, 2009"
	""
	SF-IMAGE "SF-IMAGE" 0
	SF-DRAWABLE "SF-DRAWABLE" 0
	SF-LAYER "SF-LAYER" 0
	SF-CHANNEL "SF-CHANNEL" 0
	SF-VECTORS "SF-VECTORS" 0
	SF-COLOR "SF-COLOR" '(255 255 255)
	SF-TOGGLE "SF-TOGGLE" FALSE
	SF-VALUE "SF-VALUE" "10"
	SF-STRING "SF-STRING" "The Gimp"
	SF-FILENAME "SF-FILENAME" "/FILENAME"
	SF-DIRNAME "SF-DIRNAME" ""
	SF-ADJUSTMENT "SF-ADJUSTMENT 0" '(256 1 1024 1 10 0 0)
	SF-ADJUSTMENT "SF-ADJUSTMENT 1" '(256 1 1024 1 10 0 1)
	SF-FONT "SF-FONT" "Sans"
	SF-PATTERN "SF-PATTERN" "Leopard"
	SF-BRUSH "SF-BRUSH" '("Circle (15)" 1.0 20 0)
	SF-GRADIENT "SF-GRADIENT" "Blue Green"
	SF-OPTION "SF-OPTION" '("Option1" "Option2" "Option3")
	SF-PALETTE "SF-PALETTE" "Blues"
	SF-TEXT "SF-TEXT" "Try input \n any texts"
	SF-ENUM "SF-ENUM" '("GimpGradientType" "linear")
	SF-DISPLAY "SF-DISPLAY" 0
	)
	(script-fu-menu-register "script-fu-all-inputs-box"
	"<Image>/Filters/Test")

view raw all-inputs-box.scm hosted with ❤ by GitHub

	;; ドロップシャドウを追加するスクリプト
	(define (script-fu-layer-effect-drop-shadow
	img ; 画像
	layer ; ドロアブル (レイヤー)
	shadow-color ; 影の色
	blur-radius ; 影のぼかし半径
	opacity ; 影の不透明度
	x-offset ; 影の X オフセット
	y-offset ; 影の Y オフセット
	)
	(let ((width (car gimp-drawable-width layer))
	(height (car (gimp-drawable-height layer))))
	(let ((shadow-layer (car (gimp-layer-new img width height RGBA-IMAGE
	"Drop Shadow" opacity MULTIPLY-MODE))))
	(let ((shadow-mask (car (gimp-layer-create-mask shadow-layer BLACK-MASK))))
	;; 処理準備
	(gimp-image-undo-group-start img)
	(gimp-context-push)
	(gimp-image-add-layer img shadow-layer -1)
	(gimp-image-add-layer-mask img shadow-layer shadow-mask)
	;; シャドウレイヤーマスクの作成
	(gimp-context-set-background shadow-color)
	(gimp-drawabla-fill shadow-layer BG-IMAGE-FILL)
	(gimp-selection-layer-alpha layer)
	(gimp-edit-fill shadow-mask WHITE-IMAGE-FILL)
	(gimp-selection-none img)
	;; シャドウレイヤーマスクへの変更
	(gimp-context-set-background '(0 0 0))
	(gimp-channel-ops-offset shadow-mask FALSE OFFSET-BACKGROUND x-offset y-offset)
	(plug-in-gauss-iir2 1 img shadow-mask blur-radius blur-radius)
	;; 後処理
	(gimp-image-lower-layer img shadow-layer)
	(gimp-context-pop)
	(gimp-image-undo-group-end img)
	(gimp-displays-flush)))))
	(script-fu-register
	"script-fu-layer-effect-drop-shadow"
	"Drop Shadow..."
	"Create drop shadow on the layer with alpha"
	"iccii <iccii@hotmail.com"
	"iccii"
	"Aug, 2001/May, 2009"
	"RGBA"
	SF-IMAGE "Image" 0
	SF-DRAWABLE "Drawable" 0
	SF-COLOR "Shadow color" '(0 0 0)
	SF-ADJUSTMENT "Shadow blur radius" '(10 1 100 1 10 0 0)
	SF-ADJUSTMENT "Drop shadow opacity" '(75 0 100 1 10 0 0)
	SF-ADJUSTMENT "Shadow X offset" '(5 -100 100 1 10 0 1)
	SF-ADJUSTMENT "Shadow Y offset" '(5 -100 100 1 10 0 1))
	(script-fu-menu-register "script-fu-layer-effect-drop-shadow"
	"<Image>/Filters/Layer Effect")

view raw layer-effect-drop-shadow.scm hosted with ❤ by GitHub

	;; レイヤー光彩 (内側) スクリプト
	(define (script-fu-layer-effect-inner-glow
	img ; 画像
	layer ; ドロアブル (レイヤー)
	glow-color ; 光彩の色
	blur-radius ; 光彩のぼかし半径
	glow-radius ; 光彩の半径
	opacity ; 光彩の不透明度
	glow-type ; 光彩のタイプ (縁 or 内部)
	)
	(let ((width (car (gimp-drawable-width layer)))
	(height (car (gimp-drawable-height layer))))
	(let ((glow-layer (car (gimp-layer-new img width height RGBA-IMAGE
	"Inner Glow" opacity SCREEN-MODE))))
	(let ((glow-mask (car (gimp-layer-create-mask glow-layer WHITE-MASK))))
	;; 処理準備
	(gimp-image-undo-group-start img)
	(gimp-context-push)
	(gimp-image-add-layer img glow-layer -1)
	(gimp-image-add-layer-mask img glow-layer glow-mask)
	;; 光彩レイヤーマスクの作成
	(gimp-context-set-background glow-color)
	(gimp-drawable-fill glow-layer BG-IMAGE-FILL)
	(gimp-selection-layer-alpha layer)
	(gimp-selection-invert img)
	(gimp-selection-grow img glow-radius)
	(gimp-selection-invert img)
	(gimp-context-set-background '(0 0 0))
	(gimp-edit-fill glow-mask BG-IMAGE-FILL)
	(gimp-selection-none img)
	;; 光彩レイヤーマスクへの変更
	(plug-in-gauss-iir2 1 img glow-mask blur-radius blur-radius)
	(and (eqv? glow-type 1)
	(gimp-invert glow-mask))
	;; もう一度レイヤーマスクを作る
	(gimp-image-remove-layer-mask img glow-layer APPLY)
	(let ((glow-mask2 (car (gimp-layer-create-mask glow-layer BLACK-MASK))))
	(gimp-image-add-layer-mask img glow-layer glow-mask2)
	(gimp-selection-layer-alpha layer)
	(gimp-edit-fill glow-mask2 WHITE-IMAGE-FILL)
	(gimp-selection-none img)
	;; 後処理
	(gimp-context-pop)
	(gimp-image-undo-group-end img)
	(gimp-displays-flush))))))
	(script-fu-register
	"script-fu-layer-effect-inner-glow"
	"Inside Glow..."
	"Create inner glow on the layer with alpha"
	"Iccii <iccii@hotmail.com>"
	"Iccii"
	"Aug, 2001/May, 2009"
	"RGBA"
	SF-IMAGE "Image" 0
	SF-DRAWABLE "Drawable" 0
	SF-COLOR "Glow color" '(255 255 191)
	SF-ADJUSTMENT "Blur radius" '(10 1 100 1 10 0 0)
	SF-ADJUSTMENT "Glow radius" '(2 1 100 1 10 0 0)
	SF-ADJUSTMENT "Opacity" '(75 0 100 1 10 0 0)
	SF-OPTION "Glow type" '("Edge" "Inner")
	)
	(script-fu-menu-register "script-fu-layer-effect-inner-glow"
	"<Image>/Filters/Layer Effect")

view raw layer-effect-inner-grow.scm hosted with ❤ by GitHub

	;; レイヤー光彩 (外側) スクリプト
	(define (script-fu-layer-effect-outer-glow
	img ; 画像
	layer ; ドロアブル (レイヤー)
	glow-color ; 光彩の色
	blur-radius ; 光彩のぼかし半径
	glow-radius ; 光彩の半径
	opacity ; 光彩の不透明度
	)
	(let ((width (car (gimp-drawable-width layer)))
	(height (car (gimp-drawable-height layer))))
	(let ((glow-layer (car (gimp-layer-new img width height RGBA-IMAGE
	"Outer Glow" opacity SCREEN-MODE))))
	(let ((glow-mask (car (gimp-layer-create-mask glow-layer BLACK-MASK))))
	;; 処理準備
	(gimp-image-undo-group-start img)
	(gimp-context-push)
	(gimp-image-add-layer img glow-layer -1)
	(gimp-image-add-layer-mask img glow-layer glow-mask)
	;; 光彩レイヤーマスクの作成
	(gimp-context-set-background glow-color)
	(gimp-drawable-fill glow-layer BG-IMAGE-FILL)
	(gimp-selection-layer-alpha layer)
	(gimp-selection-grow img glow-radius)
	(gimp-edit-fill glow-mask WHITE-IMAGE-FILL)
	(gimp-selection-none img)
	;; 光彩レイヤーマスクへの変更
	(gimp-context-set-background '(0 0 0))
	(plug-in-gauss-iir2 1 img glow-mask blur-radius blur-radius)
	;; 後処理
	(gimp-image-lower-layer img glow-layer)
	(gimp-context-pop)
	(gimp-image-undo-group-end img)
	(gimp-displays-flush)))))
	(script-fu-register
	"script-fu-layer-effect-outer-glow"
	"Outer Glow..."
	"Create outer glow on the layer with alpha"
	"Iccii <iccii@hotmail.com>"
	"Iccii"
	"Aug, 2001/May, 2009"
	"RGBA"
	SF-IMAGE "Image" 0
	SF-DRAWABLE "Drawable" 0
	SF-COLOR "Glow color" '(255 255 191)
	SF-ADJUSTMENT "Blur radius" '(10 1 100 1 10 0 0)
	SF-ADJUSTMENT "Glow radius" '(2 1 100 1 10 0 0)
	SF-ADJUSTMENT "Opacity" '(75 0 100 1 10 0 0)
	)
	(script-fu-menu-register "script-fu-layer-effect-outer-glow"
	"<Image>/Filters/Layer Effect")

view raw layer-effect-outer-grow.scm hosted with ❤ by GitHub

	;; レイヤー光彩 (内側) スクリプト
	(define (script-fu-layer-effect-inner-glow
	img ; 画像
	layer ; ドロアブル (レイヤー)
	glow-color ; 光彩の色
	blur-radius ; 光彩のぼかし半径
	glow-radius ; 光彩の半径
	opacity ; 光彩の不透明度
	glow-type ; 光彩のタイプ (縁 or 内部)
	)
	(let ((width (car (gimp-drawable-width layer)))
	(height (car (gimp-drawable-height layer))))
	(let ((glow-layer (car (gimp-layer-new img width height RGBA-IMAGE
	"Inner Glow" opacity SCREEN-MODE))))
	(let ((glow-mask (car (gimp-layer-create-mask glow-layer WHITE-MASK))))
	;; 処理準備
	(gimp-image-undo-group-start img)
	(gimp-context-push)
	(gimp-image-add-layer img glow-layer -1)
	(gimp-image-add-layer-mask img glow-layer glow-mask)
	;; 光彩レイヤーマスクの作成
	(gimp-context-set-background glow-color)
	(gimp-drawable-fill glow-layer BG-IMAGE-FILL)
	(gimp-selection-layer-alpha layer)
	(gimp-selection-invert img)
	(gimp-selection-grow img glow-radius)
	(gimp-selection-invert img)
	(gimp-context-set-background '(0 0 0))
	(gimp-edit-fill glow-mask BG-IMAGE-FILL)
	(gimp-selection-none img)
	;; 光彩レイヤーマスクへの変更
	(plug-in-gauss-iir2 1 img glow-mask blur-radius blur-radius)
	(and (eqv? glow-type 1)
	(gimp-invert glow-mask))
	;; もう一度レイヤーマスクを作る
	(gimp-image-remove-layer-mask img glow-layer APPLY)
	(let ((glow-mask2 (car (gimp-layer-create-mask glow-layer BLACK-MASK))))
	(gimp-image-add-layer-mask img glow-layer glow-mask2)
	(gimp-selection-layer-alpha layer)
	(gimp-edit-fill glow-mask2 WHITE-IMAGE-FILL)
	(gimp-selection-none img)
	;; 後処理
	(gimp-context-pop)
	(gimp-image-undo-group-end img)
	(gimp-displays-flush))))))
	(script-fu-register
	"script-fu-layer-effect-inner-glow"
	"Inside Glow..."
	"Create inner glow on the layer with alpha"
	"Iccii <iccii@hotmail.com>"
	"Iccii"
	"Aug, 2001/May, 2009"
	"RGBA"
	SF-IMAGE "Image" 0
	SF-DRAWABLE "Drawable" 0
	SF-COLOR "Glow color" '(255 255 191)
	SF-ADJUSTMENT "Blur radius" '(10 1 100 1 10 0 0)
	SF-ADJUSTMENT "Glow radius" '(2 1 100 1 10 0 0)
	SF-ADJUSTMENT "Opacity" '(75 0 100 1 10 0 0)
	SF-OPTION "Glow type" '("Edge" "Inner")
	)
	(script-fu-menu-register "script-fu-layer-effect-inner-glow"
	"<Image>/Filters/Layer Effect")

view raw layer-effect-inner-grow.scm hosted with ❤ by GitHub

プロダクション・システム

	;; 前向き推論はつぎの3つのステップの繰り返しによって実現される
	;; Step1 照合(パターンマッチング)
	;; ルールベースの中のすべてのプロダクションルールの条件部とワー
	;; キングメモリーの内容とを照合し、実行可能なルールの集まり
	;; を探す。実行可能なルールがなければ終了する。
	;; Step2 競合の解消
	;; 実行可能なルールの集まりの中から実際に実行するルールを1
	;; つ選択する。以下の例ではユーザーがこれを行う。
	;; Step3 動作
	;; 競合の解消によって選ばれたルールの結論部を実行する。これ
	;; によりワーキングメモリーの内容は更新される。
	;;;; プロダクションルールの実現
	(define (get-rulename rule) (car rule))
	(define (get-cond rule) (cadr rule))
	(define (get-action rule) (fourth rule))
	;;;; 推論エンジンの実現
	(define (forward-reasoning memory)
	;; Step-1 照合と Step-2 競合解消
	(let loop ((rule (choice (pattern-matching memory)))
	(memory memory))
	;; 実行可能なルールがなければ終了
	;; quit が入力されたら終了
	(if (or (null? rule) (eq? rule 'quit))
	'end
	(let ((memory (rule-action rule memory))) ;Step-3 動作
	(output-data memory) ;ワーキングメモリーの出力
	(loop (choice (pattern-matching memory))
	memory)))))
	;; ワーキングメモリの内容を出力する手続き
	(define (output-data memory)
	(printn " *working-memory* :" memory))
	;; すべての引数を印字したのち改行する手続き
	(define (printn . x)
	(for-each display x)
	(newline))
	;;;; 照合 : pattern-matching
	;;; pattern-matching は、ワーキングメモリーの内容 states とルールベー
	;;; ス *rule-base* から実行可能なルールの集まりを求める手続き
	;; PLT 実装依存の filter を使ったヴァージョン
	;; SRFI-1 を用いても良い
	(define (pattern-matching states)
	;; 全体が評価値
	(map get-rulename
	;; 偽ならそのルールをフィルタリングする
	(filter (lambda (candidate) ;対象とするルール
	(rule-cond? (get-cond candidate) states))
	*rule-base*)))
	;; プロダクションルールの条件部 conds がワーキ
	;; ングメモリー states に含まれているかどうかを
	;; 調べる手続き
	(define (rule-cond? conds states)
	(or (null? conds)
	(if (eq? (car conds) 'and) ;論理積であるか？
	(condition-aux? (cdr conds) states)
	(member conds states)))) ;単独の場合
	(define (condition-aux? conds states) ;論理積の場合
	(or (null? conds)
	(and (member (car conds) states)
	(condition-aux? (cdr conds) states))))
	;;;; 競合解消 : choice
	;; 選択されたルールのルール名を評価値とする
	(define (choice lst) ;lst は実行可能なルールの集まり
	(cond ((null? lst) '())
	(else
	(printn "enable rules : " lst)
	(display "enter rule-name >> ")
	(read)))) ;ルール名の読み込み
	;;;; 実行 : rule-action
	;; ルールの結論部を実行することで、ワーキングメモリーの内容 memory を
	;; 変更する手続き
	(define (rule-action r memory) ; r はルール名
	(let ((rule (get-rule r *rule-base*)))
	(if (null? rule)
	memory
	;; ルールの実行部を評価する
	(eval-action (get-action rule) memory))))
	;; ルール集合 rules の中のルール名 r の内容を評価値とする手
	;; 続き
	(define (get-rule r rules) ; rules はルール集合
	(if (null? rules)
	'() ; rules はルールベース
	(let ((rule (car rules)))
	(if (eq? (car rule) r) ;ルール名のチェック
	rule ;選択されたルール
	(get-rule r (cdr rules))))))
	;;;; ルールベースの表現
	(define *rule-base*
	'((rule1 (and (USA) (English)) --> (Honolulu))
	(rule2 (and (Europe) (France)) --> (Paris))
	(rule3 (and (USA) (Continent)) --> (LosAngels))
	(rule4 (and (Island) (Equator)) --> (Honolulu))
	(rule5 (and (Asia) (Equator)) --> (Singapore))
	(rule6 (and (Island) (Micronesia)) --> (Guam))
	(rule7 (Swimming) --> (Equator))))
	;;;; ワーキングメモリーの表現
	(define *working-memory* '((Island) (Swimming)))
	;;;; eval-action
	(define (eval-action action memory) ; action は実行される結論部
	(printn "action : " action) ;追加される結論部の表示
	(cons action memory)) ;結論部の追加 & memory の内容が評価値
	;; ;; 実行例
	;; > (forward-reasoning *working-memory*)
	;; enable rules : (rule7)
	;; enter rule-name >> rule7
	;; action : (Equator)
	;; *working-memory* :((Equator) (Island) (Swimming))
	;; enable rules : (rule4 rule7)
	;; enter rule-name >> rule4
	;; action : (Honolulu)
	;; *working-memory* :((Honolulu) (Equator) (Island) (Swimming))
	;; enable rules : (rule4 rule7)
	;; enter rule-name >> quit
	;; end
	;; >

view raw forward-reasoning.ss hosted with ❤ by GitHub

	;;;; ルールベースの表現
	;; ・もし、積木 x の上に何もないならば、x をテーブルの上に置く。こ
	;; れを (on x table) と表現する。
	;; ・もし、積木 x と y の上に何もないならば、 x を y の上に積む。こ
	;; れを (on x y) と表現する。
	(define *rule-base*
	'((rule1 (clear a) --> (on a table))
	(rule2 (clear b) --> (on b table))
	(rule3 (clear c) --> (on c table))
	(rule4 (and (clear a) (clear b)) --> (on a b))
	(rule5 (and (clear a) (clear c)) --> (on a c))
	(rule6 (and (clear b) (clear a)) --> (on b a))
	(rule7 (and (clear b) (clear c)) --> (on b c))
	(rule8 (and (clear c) (clear a)) --> (on c a))
	(rule9 (and (clear c) (clear b)) --> (on c b))))
	;;;; 積み木の世界の実行部
	;; (on x y) 形式で表現されている結論部を実行
	(define (eval-action rule memory) ; memory はワーキングメモリの内容
	(let ((act (car rule)))
	(if (eq? act 'on)
	(on (cadr rule) (third rule) memory) ; on の実行
	'())))
	;; 第1引数 x を第2引数 y の上に置く操作を実現
	(define (on x y memory)
	;; (clear y) を除き
	;; (on x y) になってたら (clear z) を加え、 (on x z) を除き
	;; (on x y) を加え評価値とする
	(cons `(on ,x ,y)
	(insert-clear x (remove-clear y memory))))
	;; (remove-clear 'c '((on a table) (on c a) (clear c)))
	;; ===> ((on a table) (on c a))
	(define (remove-clear foo lst)
	(let loop ((lst lst) (acc '()))
	(if (null? lst)
	(reverse acc)
	(let ((item (car lst))
	(state (caar lst))
	(block (cadar lst)))
	(loop (cdr lst)
	(if (and (eq? block foo) (eq? state 'clear))
	acc
	(cons item acc)))))))
	;; (insert-clear 'c '((on a table) (on c a) (clear c)))
	;; ===> ((on a table) (clear a) (clear c))
	(define (insert-clear foo lst)
	(let loop ((lst lst) (acc '()))
	(if (null? lst)
	(reverse acc)
	(let ((item (car lst))
	(state (caar lst))
	(block (cadar lst)))
	(loop (cdr lst)
	(call/cc
	(lambda (k)
	(cons
	(cond
	((not (and (eq? block foo) (eq? state 'on)))
	item)
	((eq? (caddr item) 'table)
	(k acc))
	(else
	`(clear ,(caddr item))))
	acc))))))))
	;;;; プロダクションルールの実現
	(define (get-rulename rule) (car rule))
	(define (get-cond rule) (cadr rule))
	(define (get-action rule) (fourth rule))
	;;;; 推論エンジンの実現
	(define (forward-reasoning memory)
	;; Step-1 照合と Step-2 競合解消
	(let loop ((rule (choice (pattern-matching memory)))
	(memory memory))
	;; 実行可能なルールがなければ終了
	;; quit が入力されたら終了
	(if (or (null? rule) (eq? rule 'quit))
	'end
	(let ((memory (rule-action rule memory))) ;Step-3 動作
	(output-data memory) ;ワーキングメモリーの出力
	(loop (choice (pattern-matching memory))
	memory)))))
	;; ワーキングメモリの内容を出力する手続き
	(define (output-data memory)
	(printn " *working-memory* :" memory))
	;; すべての引数を印字したのち改行する手続き
	(define (printn . x)
	(for-each display x)
	(newline))
	;;;; 照合 : pattern-matching
	;;; pattern-matching は、ワーキングメモリーの内容 states とルールベー
	;;; ス *rule-base* から実行可能なルールの集まりを求める手続き
	;; PLT 実装依存の filter を使ったヴァージョン
	;; SRFI-1 を用いても良い
	(define (pattern-matching states)
	;; 全体が評価値
	(map get-rulename
	;; 偽ならそのルールをフィルタリングする
	(filter (lambda (candidate) ;対象とするルール
	(rule-cond? (get-cond candidate) states))
	*rule-base*)))
	;; プロダクションルールの条件部 conds がワーキ
	;; ングメモリー states に含まれているかどうかを
	;; 調べる手続き
	(define (rule-cond? conds states)
	(or (null? conds)
	(if (eq? (car conds) 'and) ;論理積であるか？
	(condition-aux? (cdr conds) states)
	(member conds states)))) ;単独の場合
	(define (condition-aux? conds states) ;論理積の場合
	(or (null? conds)
	(and (member (car conds) states)
	(condition-aux? (cdr conds) states))))
	;;;; 競合解消 : choice
	;; 選択されたルールのルール名を評価値とする
	(define (choice lst) ;lst は実行可能なルールの集まり
	(cond ((null? lst) '())
	(else
	(printn "enable rules : " lst)
	(display "enter rule-name >> ")
	(read)))) ;ルール名の読み込み
	;;;; 実行 : rule-action
	;; ルールの結論部を実行することで、ワーキングメモリーの内容 memory を
	;; 変更する手続き
	(define (rule-action r memory) ; r はルール名
	(let ((rule (get-rule r *rule-base*)))
	(if (null? rule)
	memory
	;; ルールの実行部を評価する
	(eval-action (get-action rule) memory))))
	;; ルール集合 rules の中のルール名 r の内容を評価値とする手
	;; 続き
	(define (get-rule r rules) ; rules はルール集合
	(if (null? rules)
	'() ; rules はルールベース
	(let ((rule (car rules)))
	(if (eq? (car rule) r) ;ルール名のチェック
	rule ;選択されたルール
	(get-rule r (cdr rules))))))
	;; ;; 実行例
	;; > (define *working-memory*
	;; '((on a table) (clear b) (on b table) (on c a)
	;; (clear c)))
	;; > (forward-reasoning *working-memory*)
	;; enable rules : (rule2 rule3 rule7 rule9)
	;; enter rule-name >> rule3
	;; *working-memory* :((on c table) (on a table) (clear b) (on b table) (clear a) (clear c))
	;; enable rules : (rule1 rule2 rule3 rule4 rule5 rule6 rule7 rule8 rule9)
	;; enter rule-name >> rule7
	;; *working-memory* :((on b c) (on c table) (on a table) (clear b) (clear a))
	;; enable rules : (rule1 rule2 rule4 rule6)
	;; enter rule-name >> rule4
	;; *working-memory* :((on a b) (on b c) (on c table) (clear a))
	;; enable rules : (rule1)
	;; enter rule-name >> quit
	;; end
	;; >

view raw bricks.ss hosted with ❤ by GitHub

	;;;; ルールベースの表現
	(define *rule-base*
	'((rule1 (and (USA) (English)) --> (Honolulu))
	(rule2 (and (Europe) (France)) --> (Paris))
	(rule3 (and (USA) (Continent)) --> (LosAngels))
	(rule4 (and (Island) (Equator)) --> (Honolulu))
	(rule5 (and (Asia) (Equator)) --> (Singapore))
	(rule6 (and (Island) (Micronesia)) --> (Guam))
	(rule7 (Swimming) --> (Equator))))
	;;;; ワーキングメモリーの表現
	(define *working-memory* '((Honolulu)))
	;;;; 推論エンジンの実現
	;; Step1 照合
	;; 目標をルールの結論部として含むルールの集まりを探す。その
	;; ようなルールがなければ、仮定は否定されたとして終了する。
	;; Step2 競合の解消
	;; ルールの集まりの中からルールを1つ選択する。前向き推論と
	;; 同様に、ユーザーがこれを行うものとする。
	;; Step3 動作
	;; 選択されたルールの条件部への各要素がつぎの条件のいずれかを
	;; 満たしていれば、これらを新しい目標値とし、Step1 へと戻る。
	;; 1) 他のルールへの結論部として含まれている。
	;; 2) ユーザーへの問い合わせによって肯定された。
	;; これらの条件が満足されなければ、仮定は否定されたこととし
	;; て終了する。
	(define (backward-reasoning memory) ;目標を memory とする
	;; Step-1 最初の目標の照合と Step-2 競合解消
	(let loop ((rule (choice (pattern-matching-back memory)))
	(memory memory))
	;; 実行可能なルールがなければ終了
	;; quit が入力されたら終了
	(if (or (null? rule) (eq? rule 'quit))
	'end
	(let ((memory (rule-action-back rule))) ; Step-3 動作
	(output-data-back memory) ; 結果の出力
	(loop (choice (pattern-matching-back memory)) memory)))))
	;;; 仮定が成立しないときに、そのことを出力する手続き
	(define (output-data-back item)
	(and (null? item)
	(printn (caar *working-memory*)
	" is unsuitable for you.")))
	;; すべての引数を印字したのち改行する手続き
	(define (printn . x)
	(for-each display x)
	(newline))
	;;;; 競合解消 : choice
	;; 選択されたルールのルール名を評価値とする
	(define (choice lst) ;lst は実行可能なルールの集まり
	(cond ((null? lst) '())
	(else
	(printn "enable rules : " lst)
	(display "enter rule-name >> ")
	(read)))) ;ルール名の読み込み
	;;;; 照合 : pattern-matching-back
	;;; states で表される結論部をもつルールを
	;;; *rule-base* から探す手続き
	(define (pattern-matching-back states)
	;; 全体が評価値
	(map get-rulename ;以降が真ならそのルールを含める
	(filter (lambda (candidate) ;対象とするルール
	(rule-cond? (get-action candidate) states))
	*rule-base*)))
	;; プロダクションルールの条件部 conds がワーキ
	;; ングメモリー states に含まれているかどうかを
	;; 調べる手続き
	(define (rule-cond? conds states)
	(or (null? conds)
	(if (eq? (car conds) 'and) ;論理積であるか？
	(condition-aux? (cdr conds) states)
	(member conds states)))) ;単独の場合
	(define (condition-aux? conds states) ;論理積の場合
	(or (null? conds)
	(and (member (car conds) states)
	(condition-aux? (cdr conds) states))))
	;;;; プロダクションルールの実現
	(define (get-rulename rule) (car rule))
	(define (get-cond rule) (cadr rule))
	(define (get-action rule) (fourth rule))
	;;;; 実行 : rule-action-back
	;;; 選択されたルールの条件部が論理積の形式である
	;;; かどうかに応じて、 eval-action-back を呼び出し、
	;;; 新しい目標とすべき要素のリストを返す
	(define (rule-action-back r) ; r は選択されたルール名
	(let ((rule (get-rule r *rule-base*))) ;ルール r を取り出す
	(if (null? rule)
	'()
	(let ((items (get-cond rule)))
	(let ((item (car items)))
	(eval-action-back
	(if (eq? item 'and) ;論理積であるか?
	(cdr items) ;論理積の場合
	`(,items))
	'()))))))
	(define (eval-action-back items lst)
	(if (null? items)
	lst
	(let ((item (car items)))
	(let ((rules (pattern-matching-back `(,item))))
	(call/cc
	(lambda (k)
	(eval-action-back (cdr items)
	;; 条件部が他のルールの結論部に含まれている場合
	(if (or (pair? rules)
	;; あるいはユーザーに質問
	(eq? (question item) 'y))
	;; 論理積で記述されているならばつぎの条件の評価
	(cons item lst)
	(k '())))))))))
	(define (question lst)
	(and (pair? lst)
	(begin
	(printn "Do you feel satisfied next condition ?")
	(printn (car lst)) ;条件の表示
	(display "Please input 'y' or 'n' >> ")
	(read)))) ; y, n の読み込み
	;; ルール集合 rules の中のルール名 r の内容を評価値とする手
	;; 続き
	(define (get-rule r rules) ; rules はルール集合
	(if (null? rules)
	'() ; rules はルールベース
	(let ((rule (car rules)))
	(if (eq? (car rule) r) ;ルール名のチェック
	rule ;選択されたルール
	(get-rule r (cdr rules))))))
	;; ;; 実行例
	;; > (backward-reasoning *working-memory*)
	;; enable rules : (rule1 rule4)
	;; enter rule-name >> rule4
	;; Do you feel satisfied next condition ?
	;; Island
	;; Please input 'y' or 'n' >> y
	;; enable rules : (rule7)
	;; enter rule-name >> rule7
	;; Do you feel satisfied next condition ?
	;; Swimming
	;; Please input 'y' or 'n' >> y
	;; end
	;; >

view raw backward-reasoning.ss hosted with ❤ by GitHub

dot-emacs-example.el

Emacs Newbiesの為に.emacsの雛形を公開します。Emacs23以上対応です。

以前、UbuntuのEmacs22辺りまではUbuntu Japanese Team制作のdot.emacs.exampleが同梱されていたのですが、Emacs23からは完全UTF-8対応になった為か、無くなってしまいました。
そこで利便性を考え、オリジナル(GPLライセンス)のdot.emacs.exampleを改造したのが以下のdot-emacs-example.elです。

勝手に持って行って下さい(笑)。

	;;=======================================================================
	;; map-dir-list-into-load-path の定義
	;;=======================================================================
	;; rubikitch さん作のユーティリティ
	;; http://d.hatena.ne.jp/rubikitch/20090609/1244484272
	(defun add-to-load-path-recompile (dir)
	(add-to-list 'load-path dir)
	(let (save-abbrevs) (byte-recompile-directory dir)))
	(defun map-dir-list-into-load-path (dir-lst)
	(mapcar #'(lambda (x)
	(add-to-load-path-recompile
	(expand-file-name x)))
	dir-lst))
	;;
	;;=======================================================================
	;; パスを通す
	;;=======================================================================
	(defvar *dot-emacs-load-path-list*
	'("~/.emacs.d/auto-install"
	;; ここで文字列でパスを通したいディレクトリを指定する
	;; 例： "/i/want/to/make/a/path/to/the/directory"
	))
	(map-dir-list-into-load-path *dot-emacs-load-path-list*)
	;;
	;;=======================================================================
	;; dot-emacs-requirements-list
	;;=======================================================================
	(defvar *dot-emacs-requirements-list*
	'(cl
	session
	;; 必要な機能があったらここに書き込む
	;; 例： auto-install
	))
	(mapcar #'require *dot-emacs-requirements-list*)
	;;
	;;=======================================================================
	;; フレームサイズ
	;;=======================================================================
	(defvar *dot-emacs-frame-setting-list*
	'((width . 90) ; フレームの幅
	(height . 49) ; フレームの高さ
	(top . 0) ; Y 表示位置
	(left . 340) ; X 表示位置
	(alpha . (100 25)))) ; 透明度
	(loop for i in *dot-emacs-frame-setting-list*
	do (add-to-list 'initial-frame-alist i))
	(setf default-frame-alist initial-frame-alist)
	;;
	;;=======================================================================
	;; Misc
	;;=======================================================================
	(mouse-wheel-mode t) ;;ホイールマウス
	(global-font-lock-mode t) ;;文字の色つけ
	(setf line-number-mode t) ;;カーソルのある行番号を表示
	(auto-compression-mode t) ;;日本語infoの文字化け防止
	(set-scroll-bar-mode 'right) ;;スクロールバーを右に表示
	(global-set-key "\C-z" 'undo) ;;UNDO
	(setf frame-title-format ;;フレームのタイトル指定
	(concat "%b - emacs@" system-name))
	(display-time) ;;時計を表示
	;; (global-set-key "\C-h" 'backward-delete-char) ;;Ctrl-Hでバックスペース
	;; (setf make-backup-files nil) ;;バックアップファイルを作成しない
	;; (setf visible-bell t) ;;警告音を消す
	;; (setf kill-whole-line t) ;;カーソルが行頭にある場合も行全体を削除
	;; (when (boundp 'show-trailing-whitespace)
	;; (setq-default show-trailing-whitespace t)) ;;行末のスペースを強調表示
	;;
	;;=======================================================================
	;; 履歴の保存
	;;=======================================================================
	(add-hook 'after-init-hook 'session-initialize)
	;;
	;;=======================================================================
	;; 最近使ったファイル
	;;=======================================================================
	(recentf-mode)
	;;
	;;=======================================================================
	;; リージョンに色を付ける
	;;=======================================================================
	(setf transient-mark-mode t)
	;;
	;;=======================================================================
	;; 対応する括弧を光らせる
	;;=======================================================================
	(show-paren-mode)
	;;
	;;=======================================================================
	;; C-c c で compile コマンドを呼び出す
	;;=======================================================================
	(define-key mode-specific-map "c" 'compile)
	;;
	;;=======================================================================
	;; スクリプトを保存する時、自動的に chmod +x を行うようにする
	;;=======================================================================
	;; http://www.namazu.org/~tsuchiya/elisp/#chmod
	;; を参照
	(defun make-file-executable ()
	"Make the file of this buffer executable, when it is a script source."
	(save-restriction
	(widen)
	(if (string= "#!"
	(buffer-substring-no-properties 1
	(min 3 (point-max))))
	(let ((name (buffer-file-name)))
	(or (equal ?. (string-to-char
	(file-name-nondirectory name)))
	(let ((mode (file-modes name)))
	(set-file-modes name (logior mode (logand
	(/ mode 4) 73)))
	(message (concat "Wrote " name " (+x)"))))))))
	(add-hook 'after-save-hook 'make-file-executable)
	;;
	;;=======================================================================
	;; End of File
	;;=======================================================================

view raw dot-emacs-example.el hosted with ❤ by GitHub

vallog: syntax-rules: bind-variables

vallog: syntax-rules: bind-variables

「...」だと、こうは書けないですよね。。

多分こう書くのではないでしょうか。

	(define-syntax bind-variables
	(syntax-rules ()
	((_ () form ...)
	(begin form ...))
	;; ここはオリジナルの syntax-error がどんな挙動か分からないので割愛
	;; error で置き換えてみたが、本体に form ... が無い、と怒られた
	;; ((_ ((var val0 val1 ...) ...) form ...)
	;; (error "bind-variables illegal binding" (var val0 val1 ...)))
	((_ ((var val) more-bindings ...) form ...)
	(let ((var val)) (bind-variables (more-bindings ...) form ...)))
	((_ ((var) more-bindings ...) form ...)
	(let ((var #f)) (bind-variables (more-bindings ...) form ...)))
	((_ (var more-bindings ...) form ...)
	;; ここは、本当は上のパターンに差し替えたほうが綺麗かも
	(let ((var #f)) (bind-variables (more-bindings ...) form ...)))
	((_ bindings form ...)
	(error "Bindings must be a list." bindings))
	))
	;; ;; 実行例
	;; > (bind-variables ((a 1)
	;; (b)
	;; c
	;; e
	;; (d (+ a 3)))
	;; (list a b c d e))
	;; (1 #f #f 4 #f)
	;; > (let ((a 1))
	;; (bind-variables ((b)
	;; c
	;; e
	;; (d (+ a 3)))
	;; (list a b c d e)))
	;; (1 #f #f 4 #f)
	;; > (let ((a 1))
	;; (let ((b #t))
	;; (bind-variables (c
	;; e
	;; (d (+ a 3)))
	;; (list a b c d e))))
	;; (1 #t #f 4 #f)
	;; > (bind-variables (a b c d e)
	;; (list a b c d e))
	;; (#f #f #f #f #f)
	;; > (bind-variables ((a) (b) (c) (d) (e))
	;; (list a b c d e))
	;; (#f #f #f #f #f)
	;; > (bind-variables (a (b 1) (c 2) d (e))
	;; (list a b c d e))
	;; (#f 1 2 #f #f)
	;; >

view raw bind-variables.ss hosted with ❤ by GitHub

オリジナルのコードだとsyntax-errorっての使ってますが、これはR5RSで定義されていないので、errorに差し替えています。
もっとも、2番目のパターンだとそれじゃあ怒られたので、syntax-errorの挙動がしりたいトコなんですけどねえ。

いずれにせよ、省略子で書いた方がパターン的にはシンプルなのではないでしょうか。