newLISP のクロージャ。。。または、破壊的関数の副作用（その２）

　前回の破壊的関数の副作用を使ったクロージャは、如何だったでしょうか？
　今回はその続き。元ネタは、同じく、Closures and Contexts の “Stateful functions using self modifying code” から。

　では、スクリプトです。

(define (add-quote) (letex (_x (args 0)) (quote '_x)))

(define-macro (make-stack)
; (make-stack func lst)
  (letex (_func (args 0)
          _lst (args 1))
    (define (_func x)
      (if-not x (pop '_lst)
        (setf (nth '(1 2 1) _func) (add-quote (append (eval $it) x)))))))

　今回のスクリプトのメインは、もちろん、

(pop '_lst)

　です。不思議でも何でもない？
　実際に動かしてみましょう。

> (make-stack mypop (a b c))
(lambda (x) 
 (if-not x 
  (pop '(a b c)) 
  (setf (nth '(1 2 1) mypop) (add-quote (append (eval $it) x)))))
> 

　関数 mypop が定義され、その中で pop の対象は '(a b c) になります。
　ここで、問題です。'(a b c) の型は何でしょうか？ 答えは後ほど。
　続けて実行すると、

> (mypop)
a
> (mypop)
b
> 

　そして、引数にリストを与えると、

> (mypop '(1 2 3))
'(c 1 2 3)
> mypop
(lambda (x) 
 (if-not x 
  (pop '(c 1 2 3)) 
  (setf (nth '(1 2 1) mypop) (add-quote (append (eval $it) x)))))
> (mypop)
c
> (mypop)
1
> (mypop)
2
> 

　こんな感じです。
　さて、先程の質問の解答の前に、pop のマニュアルから、

pop

syntax: (pop list [int-index-1 [int-index-2 … ]])
syntax: (pop list [list-indexes])

syntax: (pop str [int-index [int-length]])

pop を使って、リストから要素を、あるいは文字列から文字を取り去ることができます。
Using pop, elements can be removed from lists and characters from strings.

第一構文では、pop は、list を評価することで得られたリストから要素を取り出します。第二パラメータが存在するなら、int-index の要素が取り出されます。Indexing elements of strings and lists も見て下さい。
In the first syntax, pop extracts an element from the list found by evaluating list.
If a second parameter is present, the element at int-index is extracted and returned. See also Indexing elements of strings and lists.

　もうお判りですね。関数の中にある '(a b c) の型は、quote 式です（笑）。
（type-of は init.lsp に定義してあります。）

> (nth '(1 2 1) mypop)
'(c 1 2 3)
> (type-of (nth '(1 2 1) mypop))
"quote"
> 

　quote 式が評価されてリストになるので pop でき、引数のリストを追加する際には、組込 eval とquote 式に戻すための補助関数 add-quote が必要となるのです。

　さて、今回の破壊的関数の副作用を使ったクロージャは、如何でしょうか？

　あっ、もちろん、文字列も使えます。

> (make-stack mystr "123")
(lambda (x) 
 (if-not x 
  (pop '"123") 
  (setf (nth '(1 2 1) mystr) (add-quote (append (eval $it) x)))))
> (mystr)
"1"
> (mystr)
"2"
> (mystr "abc")
'"3abc"
> mystr
(lambda (x) 
 (if-not x 
  (pop '"3abc") 
  (setf (nth '(1 2 1) mystr) (add-quote (append (eval $it) x)))))
> (mystr)
"3"
> (mystr)
"a"
> (mystr)
"b"
> (mystr)
"c"
> (mystr)
""
> (mystr)
""
>  

　次回は、、、たぶん予想通り？

newLISP のクロージャ。。。または、破壊的関数の副作用

　newLISP でクロージャと言えば、コンテキストを思い浮かべますが、今回はちょっと違います。
　元ネタは、Closures and Contexts の “Stateful functions using self modifying code” から。

　先ずはスクリプトを、

(define (counter (x 1) reset-flag)
  (if-not reset-flag
      (++ 0 x)
    (counter (- x (counter)))))

　スクリプトのメインは、

(++ 0 x)

　です。0 と x の位置が逆では、と思われるかもしれませんが、ここがミソです。
　実際に動かしてみましょう。

> counter
(lambda ((x 1) reset-flag) 
 (if-not reset-flag 
  (inc 0 x) 
  (counter (- x (counter)))))
> (counter)
1
> (counter)
2
> (counter)
3
> (counter 5)
8
> (counter 0 true)
0
> (counter)
1
> counter
(lambda ((x 1) reset-flag) 
 (if-not reset-flag 
  (inc 1 x) 
  (counter (- x (counter)))))
> 

　予想通りの動作だったでしょうか？
　この動作に、先程の 0 と x の位置が重要になってきます。
　マニュアルでは、

inc

syntax: (inc place [num])

place の数値を 1.0 か オプションの数値 num 分加算し、結果を返します。inc は、浮動小数点数計算を実行し、渡された整数値を浮動小数点型に変換します。
Increments the number in place by 1.0 or by the optional number num and returns the result. inc performs float arithmetic and converts integer numbers passed into floating point type.<

place は、シンボルか、リスト構造内の位置、式によって返される数値のいずれかです。
place is either a symbol or a place in a list structure holding a
number, or a number returned by an expression.

　となっています。
　++ ではなく inc ですが、違いは整数用（ ++ ）か浮動小数点用（ inc ）かだけです。
　++ も inc も破壊的関数で、place の数値に num の数値を加算して、place の数値を置き換えます。
　そのため、上記スクリプトでは、スクリプト自体が書き換えられていく（！）訳です。つまり、破壊的関数の副作用を使ったクロージャ。

　以上、如何でしょうか？

newLISP で GUI する。。。または、自己組織化マップを表示してみる

　池谷裕二氏の著作、“単純な脳、複雑な「私」”（ISBIN：4255004323）に載っていた自己組織化マップを newLISP で書いてみました。
　スクリプトは、こんな感じ。

; utility
(define *newlispDir* (env "NEWLISPDIR"))
(load (append *newlispDir* "/guiserver.lsp"))
(include "macro.lsp")
(include "newlisp-utility.lsp")
; define global values
(define width 60)
(define cnts (/ 600 width))
(define alpha .4)
(define times 20)
; define handoler
(define (learn x m h)
  (map add m (map (curry mul h) (map sub x m))))
(define (draw tag)
  (dotimes (i cnts)
    (dotimes (j cnts)
      (gs:fill-rect tag (* i width) (* j width) width width (vectors i j))))
  (gs:update))
(define (mouse-clicked-action x y button cnt modifiers tags)
  (case button
    (1 (time (let (new-v (random 0 1 3)
             min-d 3 sel-i 0 sel-j 0)
         (dotimes (i cnts)
           (dotimes (j cnts)
             (let (ps (apply add (map (hayashi pow 2)
                                      (map sub (vectors i j) new-v))))
                (when (< ps min-d)
                  (setq min-d ps sel-i i sel-j j)))))
         (dotimes (i cnts)
           (dotimes (j cnts)
             (let (diff-i (abs (- sel-i i)) diff-j (abs (- sel-j j)))
             (cond ((zero? (+ diff-i diff-j))
                    (setf (vectors i j) (learn new-v $it alpha))
                    (setf (vectors i j) (learn new-v $it alpha))
                    (setf (vectors i j) (learn new-v $it alpha)))
                   ((or (< (+ diff-i diff-j) 2) (= diff-i diff-j 1))
                    (setf (vectors i j) (learn new-v $it alpha))
                    (setf (vectors i j) (learn new-v $it alpha)))
                   ((and (< diff-i 3) (< diff-j 3))
                    (setf (vectors i j) (learn new-v $it alpha)))
                   (true)))))) times))
    (3 (gs:set-text 'Frame 
         (string " clicked row: " (/ y width) " col:" (/ x width)
                 " vector: " (vectors  (/ x width) (/ y width)))))
    (true))
  (gs:delete-tag "R")
  (draw "R"))
; initialization
(gs:init) 
(gs:frame 'Frame 100 100 610 630 "Self-Organizing Maps Demo")
(gs:canvas 'MyCanvas 'Frame)
(gs:add-to 'Frame 'MyCanvas)
(gs:set-background 'MyCanvas gs:white)
(gs:set-anti-aliasing true)
(setq vectors (array-list (array cnts cnts)))
(dotimes (i cnts)
  (dotimes (j cnts)
    (setf (vectors i j) (random 0 1 3))))
(draw "R")
(gs:mouse-clicked 'MyCanvas 'mouse-clicked-action true)
(gs:set-visible 'Frame true)
; main
(gs:listen)
(exit)

　池谷裕二氏のプログラムと違って、二つ隣まで色を展開しています。
　動作させると、最初に

　と表示されます。
　画面を左クリックすると、
　一回目　二回目
　こんな風に、色が集まってきます。これで合ってる？
　“自己組織化マップ(Self-Organizing Maps)の基礎”を参考にして書いたのですが、私の理解が違っているかもしれません。
　
　これを何に使うのか、、、実は、試してみたかっただけ（汗）。

　以上、如何でしょうか？

newLISP v10.2.16 の翻訳マニュアル

　newLISP v10.2.16 は、開発バージョンですが、gs:table が使える guiserver v1.42 が同梱されているので常用しています。
　newLISP としても、date-list（date-value の逆関数）が追加されていたりします。
　ということで、このバージョンのマニュアルも翻訳しました。

newLISP マニュアル ＆ リファレンス v10.2.16

　もちろん、目次も日本語併記にしてあります。

　いつものように、間違いやおかしな点が有りましたら、こちらの blog までご一報下さい。

　以上、如何でしょうか？

URL エンコードとデコード

以下のスクリプトには、UTF-8 版 newLISP が必要です。

　文字コードが UTF-8 のURLエンコードは、前に紹介していますが、UTF-8版でない newLISP 用です。
　今回は、Windows でも使えるようになった UTF-8版 newLISP 用です（笑）。
　先ずは、エンコードから、

(define (char2hex ch pre flag , (d 64))
  (if (and flag (< ch 128)) (char ch)
    (let (u 0 res '())
      (while (> ch 127)
        (push (string pre (format "%2X" (+ 0x80 (% ch d)))) res)
        (setq ch (/ ch d))
        (setq u (+ 0x80 (>> u))))
      (push (string pre (format "%2X" (if (= u 0) ch (+ 0x80 (>> u) ch)))) res)
      (apply string res))))
(define (url-encode-utf8 str (pre "%") flag)
  (let (res "")
    (dostring (c str)
      (extend res (char2hex c pre flag)))))

　使い方は、

> (url-encode-utf8 "技術")
"%E6%8A%80%E8%A1%93"
> (url-encode-utf8 "技術" "")
"E68A80E8A193"
> 

　% を外せるようにした訳は、別の機会に（笑）。
　newLISP の Code Snippets にある “URL encode and decode” を参考にして、

(define (url-encode str)  
  (replace {([^a-zA-Z0-9])+} str (url-encode-utf8 $0) 0))

　と定義すれば、

> (url-encode "web技術")
"web%E6%8A%80%E8%A1%93"
> (url-encode "科学 to 技術")
"%E7%A7%91%E5%AD%A6%20to%20%E6%8A%80%E8%A1%93"
> 

　こんな感じ。
　さて、デコードは、

(module "macro.lsp")
(macro (hex2int H)  (int H 0 16))
(define (url-decode-utf8 str (pre "%"))
  (let (hexs (1 (parse str pre))
        res '())
    (while hexs
      (let (ch (hex2int (pop hexs)))
        (if (< ch 0x80) (push ch res -1)
            (< ch 0xE0) (push (+ (* 0x40 (& (hex2int ch) 0x1F))
                                 (& (hex2int (pop hexs)) 0x3F)) res -1)
            (< ch 0xF0) (push (+ (* 0x1000 (& (hex2int ch) 0x0F))
                                 (* 0x40 (& (hex2int (pop hexs)) 0x3F))
                                 (& (hex2int (pop hexs)) 0x3F)) res -1)
            (< ch 0xF8) (push (+ (* 0x40000 (& (hex2int ch) 0x07))
                                 (* 0x1000 (& (hex2int (pop hexs)) 0x3F))
                                 (* 0x40 (& (hex2int (pop hexs)) 0x3F))
                                 (& (hex2int (pop hexs)) 0x3F)) res -1)
             )))
    (apply string (map char res))))

　使い方は、

> (url-decode-utf8 "%E6%8A%80%E8%A1%93")
"技術"
> (url-decode-utf8 (append "%" (join (explode "E68A80E8A193" 2) "%")))
"技術"
> 

　何をしたいのか、一目瞭然？（笑）
　こちらも、newLISP の Code Snippets にある “URL encode and decode” を参考にして、

(define (url-decode str)
  (replace "+" str " ") ; optional
  (replace "(%[0-9A-F][0-9A-F])+" str (url-decode-utf8 $0) 0))

　と定義すれば、

> (url-decode "web%E6%8A%80%E8%A1%93")
"web技術"
> (url-decode "%E7%A7%91%E5%AD%A6%20to%20%E6%8A%80%E8%A1%93")
"科学 to 技術"
> (url-decode "%E7%A7%91%E5%AD%A6+to+%E6%8A%80%E8%A1%93")
"科学 to 技術"
> 

　こんな感じで使えます。

　以上、如何でしょうか？

正規表現表記の覚え書４。。。または、改行を含む文字列の扱い方

　前回の EPUB Viewer のスクリプトの変更部分：

    (let (book (replace {<\?.+\?>} (read-file file) "" 0))
       (replace {<meta http-equiv[^>]*>} book "" 4)

　の正規表現オプションで 4 を指定しています。
　マニュアルで正規表現オプションは、

PCRE name	no	description
PCRE_CASELESS	1	大文字を小文字として扱う treat uppercase like lowercase
PCRE_MULTILINE	2	Perl の /m のように改行で検索が制限されます。 （訳注： 行頭 (^) と行末 ($) が一行毎に使えるようになる ） limit search at a newline like Perl’s /m
PCRE_DOTALL	4	. (dot) が改行にもマッチします。 . (dot) also matches newline
PCRE_EXTENDED	8	文字クラス内以外の空白文字を無視します。 ignore whitespace except inside char class
PCRE_ANCHORED	16	（訳注：検索位置を）文字列の先頭に固定します。 anchor at the start
PCRE_DOLLAR_ENDONLY	32	$ は、改行の前ではなく、文字列の最後でマッチします。 $ matches at end of string, not before newline
PCRE_EXTRA	64	この付加機能は、現在使えません。 additional functionality currently not used
PCRE_NOTBOL	128	最初の文字は、行の先頭でないので、^ で一致しません。 first ch, not start of line; ^ shouldn’t match
PCRE_NOTEOL	256	最後の文字は、行の終わりでないので、$ で一致しません。 last char, not end of line; $ shouldn’t match
PCRE_UNGREEDY	512	数量詞の貪欲さを反転します。 invert greediness of quantifiers
PCRE_NOTEMPTY	1024	空文字列は、無効になります。 empty string considered invalid
PCRE_UTF8	2048	パターンと文字列が、UTF-8文字になります。 pattern and strings as UTF-8 characters
REPLACE_ONCE	0x8000	replaceで使われた時のみ、一回だけ置換されます。 replace only one occurrence only for use in replace
PRECOMPILED	0x10000	パターンは、プリ・コンパイルされ、RREPLACE_ONCE 0x8000とだけ結合できます。 pattern is pre-compiled, can only be combined with RREPLACE_ONCE 0x8000

　となっていて、4 は “. (dot) が改行にもマッチします。” とあります。
　どうやら、改行を含んだ文字列を扱う時は、4 を指定したほうが良さそうです。
　冒頭の正規表現表記では、. (dot) を含んでいないので 4 は要りません。
　でも私の場合、このように blog に書いておいても忘れますから、こうして置いたほうが、無難です。
　後で変更するかもしれませんからね（汗）。

　以上、如何でしょうか？

newLISP で GUI する。。。または、gs:text-pane の “text/html” モード

　EPUB Viewer で書いたように、gs:text-pane の “text/html” モードは、全ての HTML タグに対応しているわけではないようです。
　そこで、それを試すスクリプトを用意しました。

; utility
(define *newlispDir* (env "NEWLISPDIR"))
(load (append *newlispDir* "/guiserver.lsp")) 
; define sub-routine

; define handler
(define *fileName* (real-path))
(define *filemask* "htm HTM html HTML")
(define *description* "html file")
(define (openfile-action id op file)
  (when file
    (setq *fileName* (base64-dec file))
    (cond ((directory? *fileName*)
           (setq *fileName* (append  *fileName* "\\")))
          (true (gs:set-text 'InputArea (read-file *fileName*))))
    (gs:set-text 'Status *fileName*)))
(define (open-file-dialog)
  (gs:open-file-dialog 'Frame 'openfile-action *fileName* *filemask* *description*))
(define (textCallBack id text)
  (when text 
    (let (word (base64-dec text))
      (gs:set-text 'OutputArea word)
)))
(define (button-handler id)
	(gs:get-text 'InputArea 'textCallBack))

; initialization
(gs:init)
(define FPosX 50)
(define FPosY 50)
(define FWidth 800)
(define FHeight 480)
(gs:frame 'Frame FPosX FPosY FWidth FHeight "Simple HTML Tester")
(gs:panel 'ButtonPanel)
(gs:panel 'StatusPanel)
(gs:label 'Status (real-path))
(gs:button 'Button1 'button-handler "->")
(gs:button 'fileButton 'open-file-dialog "File")
(gs:text-pane 'InputArea 'gs:no-action "text/plain") 
(gs:set-syntax 'InputArea "html")
(gs:text-pane 'OutputArea 'gs:no-action "text/html")
;(gs:set-editable 'OutputArea 'nil)
(gs:split-pane 'SplitPanel "vertical" 0.5)
(gs:add-to 'SplitPanel 'InputArea 'OutputArea)
(gs:label 'TextLabel "TEXT/PLAIN mode ")
(gs:label 'HtmlLabel " TEXT/HTML mode")
(gs:add-to 'ButtonPanel 'TextLabel 'Button1 'HtmlLabel)
(gs:add-to 'StatusPanel 'fileButton 'Status)

; mount all on frame
(gs:set-border-layout 'Frame)
(gs:set-flow-layout 'ButtonPanel "center")
(gs:set-flow-layout 'StatusPanel "left")
(gs:add-to 'Frame 'ButtonPanel "north" 'SplitPanel "center" 'StatusPanel "south")
(gs:set-visible 'Frame true)

; main routine
(gs:listen)
(exit)

　これを実行すると、

　こんな感じで、左側のパネルにHTMLコードを入力して、上部真ん中のボタンを押すと右側のパネルに “text/html” モード表示されます。
　左下の File ボタンで HTML ファイルを読み込み表示させることもできます。
　保存ボタンはありません。gs:text-pane の “text/html” モードで表示できるかどうかを試すスクリプトですから（笑）。

　さて、これを使って EPUB 本体の XHTML 調べてみると、表示の邪魔しているのは、文字コードを指定してる

<meta http-equiv="Content-Type" content="application/xhtml+xml; charset=utf-8" />

　でした。<head></head> タグや <style></style> タグは、使えるようです。
　ということで、EPUB Viewer のスクリプトの内、

    (letn (str (replace {<\?.+\?>} (read-file file) "" 0)
           book1 (aif (find {<head>} str) (0 it str) str)
           book2 (aif (find {</head>} str) ((+ it 7) str) "")
           book (append book1 book2))

　の部分は、

    (let (book (replace {<\?.+\?>} (read-file file) "" 0))
       (replace {<meta http-equiv[^>]*>} book "" 4)

　で、十分だったわけです。
　また、ずいぶん、遠回りしてしまいました（汗）。
　
　以上、如何でしょうか？

newLISP の reverse を使う。

　newLISP の組込reverse は、破壊的です。マニュアルによれば、

newLISP の組込の多くは、非破壊的（ 副作用 無し）であり、既存のオブジェクトをそのまま残し、新しいオブジェクトを作ります。しかしながら、数少ない関数が、変数の内容やリスト、アレイ、文字列を変更します 。
Most of the primitives in newLISP are nondestructive (no side effects) and leave existing objects untouched, although they may create new ones. There are a few destructive functions, however, that do change the contents of a variable, list, array, or string.

　従って、Common Lisp のように reverse を使うと、副作用が問題になることがあります。
　しかし、回避方法もあります。同じくマニュアルから、

いくつかの破壊的関数は、目標オブジェクトを関数 copy で包むことによって非破壊的関数にできます。
Some destructive functions can be made non-destructive by wrapping the target object into the copy function.

(set 'aList '(a b c d e f))
(replace 'c (copy aList)) → (a b d e f)
aList → (a b c d e f)

aList のリストは、変更されずに残ります。
The list in aList is left unchanged.

　と、いった具合です。
　さて、入れ子のリスト式 の中の部分リストを reverse したい場合、

> (setq lsts '((1 2 3)(4 5 6)(7 8 9)))
((1 2 3) (4 5 6) (7 8 9))
> (setf (lsts 0) (reverse (lsts 0)))
(3 2 1)
> lsts
((3 2 1) (4 5 6) (7 8 9))
> 

　こんな感じ。えっ、$it を使わないのかって？
　それは、使ってみれば判ります。

> (setf (lsts 0) (reverse $it))

ERR: symbol is protected in function reverse : $it
> 

　$it は、保護されているシステム変数です。reverse のような破壊的関数を適用すると、エラーします。
　そのため、ここでも組込copy が必要です。

> (setf (lsts 0) (reverse (copy $it)))
(1 2 3)
> lsts
((1 2 3) (4 5 6) (7 8 9))
> 

　このように、入れ子リストの部分リストを変更するには、setf と暗黙のインデックス機能が使えます。
　そして、部分リストを全部 reverse するには map で十分ですが、

> (map reverse lsts)
((3 2 1) (6 5 4) (9 8 7))
> lsts
((1 2 3) (4 5 6) (7 8 9))
> 

　lsts 自体は変更されません。これは、組込map が非破壊なので lsts のコピーが引数として使われるためでしょう。
lsts 自体を変更するには、

> (setq lsts (map reverse lsts))
((3 2 1) (6 5 4) (9 8 7))
> lsts
((3 2 1) (6 5 4) (9 8 7))
> 

　と、するしかないようです。まっ、これで十分ですけどね（笑）。
　こんな reverse の使い方をする理由は？ それはまた、別の機会に。

　以上、如何でしょうか？

newLISP で GUI する。。。または、EPUB を表示させる？（解説編）

newLISP で GUI する。。。または、EPUB を表示させる？（解説編）

　前回の EPUB Viewer は、如何だったでしょうか？
　 EPUB の本体は、XHTML のサブセットですが、そのままでは、gs:text-pane で表示できません。
　<head></head> タグが邪魔しているようなのです。
　そのためスクリプトでは、

(letn (str (read-file file)
           book ((find {} str) str))
      (gs:set-text 'OutputArea (0 (+ (find {} book) 7) book)))

　こんな感じで、本文が入っている <body></body> を抜き出して表示させています。
　本来に立ち戻って、<head></head> タグだけを削除するなら、

(letn (str (replace {} (read-file file) "" 0)
           book1 (aif (find {} str) (0 it str) str)
           book2 (aif (find {} str) ((+ it 7) str) "")
           book (append book1 book2))
      (gs:set-text 'OutputArea book))

　こうすべきでした。先頭の削除宣言文は、xhtml の宣言文（？）の削除です。gs:text-pane では、そのまま表示されてしまうので。
　また、ファイル名を取得するには、組込directory の正規表現オプションを使って、

(directory *fileDir* "[^.+]" 1)

　としていました。これは、"." と ".." 以外のファイル名を取り込みます。
　HTMLファイルだけを取り込むようにするには、

(directory *fileDir* "html*$" 1)

　こんな感じ。ドットを付加しなかったのは、をEPUB の拡張子が .xhtml だから。
　私の場合、あんまり、正規表現にこだわると、失敗するので（汗）。
　これらを、前回の EPUB Viewer に適用すると、
（include は init.lsp に、aif は newlisp-utility.lsp に定義してあります。）

; utility
(define *newlispDir* (env "NEWLISPDIR"))
(load (append *newlispDir* "/guiserver.lsp")) 
(include "macro.lsp")

; define sub-routine
(macro (parse-path P)
  (parse P {\\|/} 0))

; define handler
(define *fileDir* (real-path))
(define *fileNames* '())
(define *index* 0)
(define *filemask* "html xhtml")
(define *description* "HTML file")
(define (book-display file)
  (when (file? file)
    (gs:set-text 'fileLabel ((parse-path file) -1))
    (letn (str (replace {<\?.+\?>} (read-file file) "" 0)
           book1 (aif (find {<head>} str) (0 it str) str)
           book2 (aif (find {</head>} str) ((+ it 7) str) "")
           book (append book1 book2))
      (replace {src="../} 
               book 
               (string {src="file:///} (join (chop (parse-path *fileDir*)) "/" true)))
      (gs:set-text 'OutputArea book))))
(define (next-action id)
  (let (f-max (length *fileNames*))
    ((if (starts-with ((parse id) -1) "pre") -- ++) *index*)
    (if (< *index*) (setq *index* (i- f-max))
        (< *index* f-max) nil
      (setq *index* 0))
    (book-display (append *fileDir* (*fileNames* *index*)))))
(define (openfile-action id op file)
  (when file
    (setq *fileDir* (base64-dec file))
    (if (directory? *fileDir*)
        (setq *fileDir* (append *fileDir* "/"))
      (let (tmp (parse-path *fileDir*))
        (setq *fileDir* (append  (join (chop tmp) "/" true)))
        (setq *fileName* (tmp -1))))
    (gs:set-text 'Status *fileDir*)
    (setq *fileNames* (sort (directory *fileDir* "html*$" 1)))
    (setq *index* 0)
    (if *fileName* (setq *index* (find *fileName* *fileNames*))
      (setq  *fileName* (*fileNames* 0)))
    (book-display (append *fileDir* (*fileNames* *index*)))))
(define (open-file-dialog)
  (gs:open-file-dialog 'Frame 'openfile-action *fileDir* *filemask* *description*))

; initialization
(gs:init)
(define FPosX 100)
(define FPosY 50)
(define FWidth 640)
(define FHeight 480)
(gs:frame 'Frame FPosX FPosY FWidth FHeight "EPUB Viewer")
(gs:panel 'ButtonPanel)
(gs:panel 'StatusPanel)
(gs:label 'Status (real-path))
(gs:label 'fileLabel "")
(gs:button 'preBtn 'next-action "<")
(gs:button 'nextBtn 'next-action ">")
(gs:button 'fileButton 'open-file-dialog "File")
;(gs:text-pane 'OutputArea 'gs:no-action  "text/plain")
(gs:text-pane 'OutputArea 'gs:no-action "text/html")
(gs:add-to 'ButtonPanel 'preBtn 'fileLabel 'nextBtn)
(gs:add-to 'StatusPanel 'fileButton 'Status)

; mount all on frame
(gs:set-border-layout 'Frame)
(gs:set-flow-layout 'ButtonPanel "center")
(gs:set-flow-layout 'StatusPanel "left")
(gs:add-to 'Frame 'ButtonPanel "north" 'OutputArea "center" 'StatusPanel "south")
(gs:set-visible 'Frame true)

; main routine
(gs:listen)
(exit)

　こうなります。
　これなら、EPUB Viewer としてだけではなく、簡易 HTML Viewer としても使える？

　以上、如何でしょうか？

newLISP で GUI する。。。または、EPUB を表示させる？

　手前味噌ですが、前の blog で short short story として書きためたものをブクログで紹介しています。
　そこから、ダウンロードできるフォーマットの一つが、EPUB。
　調べてみると EPUB は、最近話題（？）の電子書籍の一種で、XHTMLのサブセット的なファイル・フォーマットで ZIP 圧縮されたもの。
　これなら、newLISP で表示できそうだと始めてみました。
　本来なら、zip 解凍から始めるべきですが、まだ目処が付いていないので、解凍後のファイルの表示用です。
　EPUB を zip 解凍すると、

META-INF - container.xml
OEBPS    - css
         - image
         - text
         - content.opf
         - toc.ncx
mimetype

　こんな感じに展開されます。
　お目当て（笑）の short short story は、text フォルダの下に XXX.xhtml のファイル名であります。
　今回のスクリプトは、この text フォルダを指定して、中のファイルを表示するスクリプトです。

; utility
(define *newlispDir* (env "NEWLISPDIR"))
(load (append *newlispDir* "/guiserver.lsp")) 

; define sub-routine
; define handler
(define *fileDir* (real-path))
(define *fileNames* '())
(define *index* 0)
(define *filemask* "html xhtml")
(define *description* "HTML file")
(define (book-display file)
  (when (file? file)
    (gs:set-text 'Status file)
    (letn (str (read-file file)
           book ((find {<body>} str) str))
      (gs:set-text 'OutputArea (0 (+ (find {</body>} book) 7) book)))))
(define (next-action id)
  (let (f-max (length *fileNames*))
    ((if (starts-with ((parse id) -1) "pre") -- ++) *index*)
    (if (< *index*) (setq *index* (i- f-max))
        (< *index* f-max) nil
      (setq *index* 0))
    (book-display (append *fileDir* (*fileNames* *index*)))))
(define (openfile-action id op file)
  (when file
    (setq *fileDir* (base64-dec file))
    (if (directory? *fileDir*)
        (setq *fileDir* (append  *fileDir* "\\"))
      (let (tmp (parse *fileDir* {\\|/} 0))
        (setq *fileDir* (append  (join (chop tmp) "/" true)))
        (setq *fileName* (tmp -1))))
    (setq *fileNames* (sort (directory *fileDir* "[^.+]" 1)))
    (setq *index* 0)
    (if *fileName* (setq *index* (find *fileName* *fileNames*))
      (setq  *fileName* (*fileNames* 0)))
    (book-display (append *fileDir* (*fileNames* *index*)))))
(define (open-file-dialog)
  (gs:open-file-dialog 'Frame 'openfile-action *fileDir* *filemask* *description*))

; initialization
(gs:init)
(define FPosX 100)
(define FPosY 50)
(define FWidth 640)
(define FHeight 480)
(gs:frame 'Frame FPosX FPosY FWidth FHeight "EPUB Viewer")
(gs:panel 'ButtonPanel)
(gs:panel 'StatusPanel)
(gs:label 'Status (real-path))
(gs:button 'preBtn 'next-action "<")
(gs:button 'nextBtn 'next-action ">")
(gs:button 'fileButton 'open-file-dialog "File")
;(gs:text-pane 'OutputArea 'gs:no-action  "text/plain")
(gs:text-pane 'OutputArea 'gs:no-action "text/html")
(gs:add-to 'ButtonPanel 'preBtn 'nextBtn) 
(gs:add-to 'StatusPanel 'fileButton 'Status) 
; mount all on frame
(gs:set-border-layout 'Frame)
(gs:set-flow-layout 'ButtonPanel "center")
(gs:set-flow-layout 'StatusPanel "left")
(gs:add-to 'Frame 'ButtonPanel "north" 'OutputArea "center" 'StatusPanel "south")
(gs:set-visible 'Frame true)
; main routine
(gs:listen)
(exit)

　これを実行し、File ボタンを押して、解凍しておいた先程の text フォルダを指定すれば、

　といった具合に表示されます。
　ただし、テキスト・コードは、UTF-8です。つまり、UTF-8 版 newLISP で実行する必要があります。
　まだ、テキスト内容だけで、イメージ・ファイルまでは、表示できませんが（汗）。
　それに、zip 解凍も、、、

　以上、如何でしょうか？