Archive for the ‘UTF-8’ Tag

pack と unpack

 UTF-8 版 newLISP では、explode が文字単位で動作します。だから、マニュアルの例にある

> (explode "¥000¥001¥002¥003") 
("¥000" "¥001" "¥002" "¥003")

 が使えません。なので、バイナリ・データを扱う時、UTF-8 版は使えないと思っていたのですが、私の理解が足りないだけでした(汗)。元ネタは、こちら
 こういった場合、unpack を使います。

(define (str2bytes str) (unpack (dup "b" (length str)) str))

 ここで、"b" は符号なし8ビット数を指定しています。ちなみに、"c" だと符号付き8ビット数です。
 これを使えば、

> (str2bytes "¥000¥001¥002¥003") 
(0 1 2 3)

 となります。扱いやすいように数値に変換していますが、文字列のままにしたい時は、unpack"s" を指定します。

> (unpack (dup "s" 4) "¥000¥001¥002¥003") 
("¥000" "¥001" "¥002" "¥003")

 さて、バイト数列から、バイナリ・データ(文字列)に変換するには、当然 pack を使います。

(define (bytes2str lst) (pack (dup "b" (length lst)) lst))

 UTF-8 版 newLISP でなければ、(mappend は newlisp-utility.lsp に定義してあります。)

(define (bytes2str lst) (mappend char lst))
or
(define (bytes2str lst) (apply append (map char lst)))

 とも書けます。

 ということで、UTF-8 版 newLISP でもバイナリ・データを扱えるようになりました。つまり、UTF-8 版 newLISP 上でShift-JIS データを UTF-8 データに変換できるということ。
 これで、Windows 環境でも UTF-8 版 newLISP だけでアプリケーションを組めるようになりました(笑)。

 以上、如何でしょうか?

広告

newLISP で音楽を楽しむ...UTF-8化(解説編)

 “newLISP で音楽を楽しむ...UTF-8化”は、如何だったでしょうか?
  WideChar 対応で使う Windows API は、

(import "winmm.dll" "mciSendStringW")
(import "winmm.dll" "mciGetErrorStringW")

 となります。ただし、ファイル名を使わないコマンドには、WideChar は必要ないので、

(import "winmm.dll" "mciSendStringA")

 も残してあります。
 UTF-8 版 newLISP の文字列は、当然、文字コードがUTF-8 コードですので、それを WideChar に変換するには、組込unicode を使います。
 ただし、組込unicode の戻り値は、4バイトの UNICODE文字列。日本語 Windows の WideChar は、2バイトなので、変換しなければなりません。

(define (long2word str)
  (let (res "")
    (dotimes (i (/ (length str) 4))
      (let (c (slice str (* 4 i) 2))
        (unless (= c "¥000¥000")
          (extend res c))))
    res))

 組込explode暗黙のインデックス機能が使えれば良いのですが、どちらも文字単位で動作します。
 そこで、バイト単位で動作する組込slice を使って上位2バイトの “/000/000” を削除しています。
 WideChar から UTF-8 に変換するには、組込utf8 を使います。しかし、引数は 4バイトの UNICODE文字列です。
 そこで、WideChar に上位2バイトの “/000/000” を付加する関数も用意します。

(define (word2long str)
  (let (res "")
    (dotimes (i (/ (length str) 2))
      (let (c (slice str (* 2 i) 2))
        (unless (= c "¥000¥000")
          (extend res c "¥000¥000"))))
    (extend res "¥000¥000¥000¥000")))

 これらを、組込unicodeutf8 に組み合わせるだけです。

(define (toWchar str)
  (long2word (unicode str)))
(define (toChar str)
  (utf8 (word2long str)))

 関数toWchar が UTF-8 文字列を WideChar 文字列に変換し、関数toChar がその逆です。
 そして、ファイルが必要な関数 music:open と エラー内容を表示する関数 get-err-str に組み込めば終わりです。
 残りは、以前の“newLISP で音楽を楽しむ...context 化”と一緒です。

 以上、如何でしょうか?

newLISP で音楽を楽しむ...UTF-8化

 以前、Windows API を使った音楽ファイルを再生するスクリプトを紹介しましたが、WideChar には、対応していなかったので、”é” を含むようなファイル名の音楽ファイルには、使えませんでした(汗)。
 現在では、WIndows 上でも、UTF-8版 newLISP を使えるので、WideChar 対応にできるはず(guiserver.jar には開発版のV1.43がお薦め)。
 ということで、スクリプトを作ってみました。

(context 'MAIN:music) 
(import "winmm.dll" "mciSendStringW")
(import "winmm.dll" "mciSendStringA")
(import "winmm.dll" "mciGetErrorStringW")

(define l_rtnStr 128)
(define rtnStr (dup "¥000" (+ 1 l_rtnStr)))
(define (long2word str)
  (let (res "")
    (dotimes (i (/ (length str) 4))
      (let (c (slice str (* 4 i) 2))
        (unless (= c "¥000¥000")
          (extend res c))))
    res))
(define (word2long str)
  (let (res "")
    (dotimes (i (/ (length str) 2))
      (let (c (slice str (* 2 i) 2))
        (unless (= c "¥000¥000")
          (extend res c "¥000¥000"))))
    (extend res "¥000¥000¥000¥000")))
(define (toWchar str)
  (long2word (unicode str)))
(define (toChar str)
  (utf8 (word2long str)))

(define (get-err-str n)
  (mciGetErrorStringW n rtnStr l_rtnStr)
  (println (toChar rtnStr)))

(define alias-name " Music")
(define wait-time 500) 

(define (music:open m)
  (mciSendStringW (toWchar (string "open \"" m "\" alias" alias-name)) 0 0 0)) 

(define-macro (make-status)
  (letex (_cmd (string "status" alias-name " " (args 0))
          _func (sym (string (args 0))))
    (define (_func) (mciSendStringA _cmd rtnStr l_rtnStr 0) rtnStr)))
(make-status "mode")
(make-status "position")
(make-status "length") 

(define-macro (make-music)
  (letex (_cmd (string (args 0) alias-name)
          _func (sym (string (args 0))))
    (define (_func) (mciSendStringA _cmd 0 0 0)))) 
(make-music "close")
(make-music "play")
(make-music "stop")
(make-music "pause") 

(define (volume-off)
  (mciSendStringA "set Music audio all off" 0 0 0)) 
(define (volume-on)
  (mciSendStringA "set Music audio all on" 0 0 0)) 

(context MAIN)

 使い方は、“newLISP で音楽を楽しむ...context 化”と一緒ですが、動作には、Windows の UTF-8版newLISP が必要です。お間違えなく(笑)。
 WideChar対応の解説は、次回に。

 以上、如何でしょうか?

newLISP で EPUB を表示させる(改良編)

 Googleの電子書籍サービス「Google eBooks」が開始されたとのこと。
 日本は、まだ対応外なのですが、google アカウントを使って、無料の本を見ることができます。
 試しに、Charles Dickens の “Bleak House” を EPUB 形式でダウンロードして、EPUB を zip 解凍すると、

META-INF - container.xml
OEBPS    - content
         - data
         - _toc_ncx_.ncx
         - volume.opf
mimetype

 こんな感じに展開されます。ブクログにある拙作の書籍の構造とは、少し違うようです。
 また、書籍の本体は、content フォルダの下に content-XXXX.xml というファイル名になっていました。
 ということで、さっそく、拙作 EPUB-Viewer を対応させました。
 

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

; define macro
(module "macro.lsp")
(macro (parse-path P) (parse P {\\|/} 0))

; define handler
(define *fileDir* (real-path))
(define *fileNames* '())
(define *index* 0)
(define *filemask* "html xhtml xml")
(define *description* "HTML file")
(define (book-display file)
  (when (file? file)
    (let (ptmp (parse-path file)
          book (replace {<\?.+\?>} (read-file file) "" 0))
      (gs:set-text 'fileLabel (ptmp -1))
      (unless (null? book)
        (replace {<meta http-equiv[^>]*>} book "" 4)
        (replace {src="../} 
                 book 
                 (string {src="file:///} (join (chop ptmp 2) "/" 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*$|xml$" 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 "Simple 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/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)

 主な変更点は、対応ファイル拡張子(xml)の追加です(笑)。ついでに、画像の表示も。
 これを実行し、File ボタンを押して、zip 解凍しておいた先程の content フォルダを指定すれば、

 一応、対応している画像ファイルはずが、、、何故か、うまく表示されません。
 でも、本文を読むだけなら、

 問題なさそうです。
 あとは、zip 解凍か、、、(汗)

 以上、如何でしょうか?

newLISP で GUI する。。。または、天気予報を表示する。

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

 今回は、guiserver を使って、天気予報を表示させます。使う天気予報は、日本気象協会の tenki.jp のものです。
 具体的には、例えば、仙台市なら

http://tenki.jp/forecast/point-326.html

 からデータを取り出し、gs:text-pane の “text/html” モードで表示させます。
 上記 URL から分かりますように、326 が仙台市の番号です。ちなみに 1 は、札幌市です。
 ということで、スクリプトを、

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

; define global variable
;(define point 1) ; 札幌市
(define point 326) ; 仙台市
;(define point 744) ; 横浜市
;(define point 1974) ; 与那国町
(define tenki-url (string "http://tenki.jp/forecast/point-" point ".html"))

; define handler
(define (delete-tag html)
  (replace "<[^>]+>" html "" 1))
(define (delete-comment html)
  (replace "<!--[^>]+-->" html "" 0))
(define (button-handler id)
  (let (weather (get-url tenki-url))
    (regex {<div class="titleBgLong">(([^v]*)*(v+[^>][^v]*)*)</div>} weather 0)
    (gs:set-text 'leftTitle (append (delete-tag $0) (dup " " 4)))
    (letn (tmp (regex {(<table(([^e]*)*(e+[^>][^e]*)*)*/table>)} weather (+ 2048 4))
          today $1
          i (apply + (-2 tmp)))
      (gs:set-text 'TodayArea today)
      (regex {<div class="titleBgLong">(([^v]*)*(v+[^>][^v]*)*)</div>} (i weather) 0)
      (gs:set-text 'rightTitle (append (dup " " 4) (delete-tag $0)))
      (regex {(<table.+/table>)+} (i weather) (+ 2048 4))
      (gs:set-text 'WeekArea (delete-comment $0))
    )))

; initialization
(gs:init)
(define FPosX 50)
(define FPosY 50)
(define FWidth 1000)
(define FHeight 480)
(gs:frame 'Frame FPosX FPosY FWidth FHeight "天気情報 from tenki.jp")
(gs:panel 'ButtonPanel)
(gs:label 'leftTitle "")
(gs:label 'rightTitle "")
(gs:button 'Button1 'button-handler "renew")
(gs:text-pane 'TodayArea 'gs:no-action "text/html")
;(gs:set-editable 'TodayArea 'nil)
(gs:text-pane 'WeekArea 'gs:no-action "text/html")
;(gs:set-editable 'WeekArea 'nil)
(button-handler)
(gs:split-pane 'SplitPanel "vertical" 0.55)
(gs:add-to 'SplitPanel 'TodayArea 'WeekArea)
(gs:add-to 'ButtonPanel 'leftTitle 'Button1 'rightTitle)

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

; main routine
(gs:listen)
(exit)

 このスクリプトを UTF-8 版 newLISP で起動すると、

 こんな感じで表示されます。
 tenki.jp の文字コードは UTF-8 ですから、UTF-8 版 newLISP は必須です。
 Windows でも、UTF-8 版 newLISP が使えるようになっているので、この程度のスクリプトで済みました。
 UTF-8 コード使っていない Linux では、文字コード変換が必要ですけどね。
 私は、puppy Linux なので、問題ないですが。
 地域にを変えるには、

(define point 326) ; 仙台市

 の 326 を表示させたい地域の番号に変えるだけ。

 以上、如何でしょうか?

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 技術"
> 

 こんな感じで使えます。

 以上、如何でしょうか?

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 解凍も、、、

 以上、如何でしょうか?

UTF-8 版newLISP で日付を扱う。

 前回は、日付を抽出する正規表現でしたが、今回は、その後の処理。
 といっても、前に紹介した関数change-date の改良版です。
 その前に、ちょっとおさらい。

(define dateMatchStr
  {([  ]*[0-90-9]{2,4})?[  ]*[./\-・/-‐年]?([  ]*[0-90-9]{1,2}[  ]*)[./\-・/-‐月]([  ]*[0-90-9]{1,2})日?}
)
(define (number-zen2han str)
  (replace "[  ]" str "" 2048)    ; added 2010/11/ 8
  (replace "[0-9]" str (char (+ (- (char $0) 0xFF10) 0x30)) 2048))

(define (convert-2slash str)
  (trim
    (replace "[.\\-・/-‐年月日]" (number-zen2han str) "/" 2048)
    "/"))

(define (divide-with-date str (flag true))
  (let (res (regex dateMatchStr str 2048))
    (if res (list (0 (res 1) str)
                  (if flag (convert-2slash (res 0)) (res 0))
                  ((+ (res 1) (res 2)) str)))))

 おさらいと言いつつ、さりげなく正規表現文字列を変えています(汗)。区切り文字にスペース(半角と全角)を使えなくしました。なんと前と同じ、進歩のない私です(汗)。
 気のとり直して、本題です(defun と hayashi は、 newlisp-utility.lsp に定義してあります)。

(setq Today (0 3 (now (* 9 60))))

(defun strlst2date (lst)
  (let (n (length (lst 0)))
    (if (zero? n)
        (setf (lst 0) (string (Today 0)))
      (setf (lst 0) (string (chop "2000" n) $it)))
      (map (hayashi int 0 10) (map (fn (x) (replace " " x " ")) lst))))

(defun change-date (str)
  (let (slst (divide-with-date str))
    (when slst
      (let (d (/ (- (apply date-value (strlst2date (map trim (map number-zen2han (list $1 $2 $3)))))
                    (apply date-value Today))
                 24 60 60))
         (case d
           (0 (setf (slst 1) " 本日"))
           (1 (setf (slst 1) " 明日"))
           (2 (setf (slst 1) " 明後日"))
           (true (if (< d ) (setf (slst 1) (string " " (- d) "日前")))))))
      (apply string slst)))

(defun extract-date (str)
  (let (res (regex dateMatchStr (number-zen2han str) 2048))
    (when res
      (strlst2date (map trim (list $1 $2 $3))))))

 動作は、

> (change-date "9/23 テニスの日")
" 本日 テニスの日"
> (change-date "行事 9/23 テニスの日")
"行事 本日 テニスの日"
> (change-date "行事 10/9/23 テニスの日")
"行事 本日 テニスの日"
> (change-date "行事 2011/9/23 テニスの日")
"行事 2011/9/23 テニスの日"
> (change-date "祝日 11年9月23日 秋分の日")
"祝日 11/9/23 秋分の日"
> (extract-date "祝日 11年9月23日 秋分の日")
(2011 9 23)
> (extract-date "行事 9/23 テニスの日")
(2010 9 23)
> (extract-date "9/23 テニスの日")
(2010 9 23)
> 

 こんな感じ。

 以上、如何でしょうか?

UTF-8 版 newLISP で日付を抽出する。

 前の blog で紹介した “newLISP で日付を抽出する”と“newLISP で日付を抽出する(再び)”の UTF-8 対応です。
 先ずは、スクリプトから、

(define dateMatchStr 
  {([  ]*[0-90-9]{2,4})?[  ]*[./\-・/-‐年]?([  ]*[0-90-9]{1,2}[  ]*)[./\-・/-‐月]([  ]*[0-90-9]{1,2})日?}
)
(define (number-zen2han str)
  (replace "[  ]" str "" 2048)    ; added 2010/11/ 8
  (replace "[0-9]" str (char (+ (- (char $0) 0xFF10) 0x30)) 2048))

(define (convert-2slash str) 
  (trim 
    (replace "[.\\-・/-‐年月日]" (number-zen2han str) "/" 2048)
    "/"))

(define (divide-with-date str (flag true))
  (let (res (regex dateMatchStr str 2048))
    (if res (list (0 (res 1) str)
                  (if flag (convert-2slash (res 0)) (res 0))
                  ((+ (res 1) (res 2)) str)))))

 前の時のように、正規表現文字列を複数用意せずに済み、コードもすっきり(笑)。
 (2010/ 9/23 区切り文字から全角と半角のスペースを削除。)
 ちなみに、全角には、(マイナス記号)と(ハイホン記号)の両方を用意しました。また、半角の -(ハイホン-マイナス記号)の前には、\(エスケープ文字)が必要です。前の時の文字列では付いていませんが、たまたま動作する配置になっています(汗)。
 全角->半角変換には前回のスクリプトを使ってもいいのですが、数字だけなので専用にしました。漢数字も対応といきたいところですが、それはまた、別の機会に。
 動作は、

> (divide-with-date "出張 3/13 横浜")
("出張" "3/13" " 横浜")
> (divide-with-date "10月11日芋煮会")
("" "10/11" "芋煮会")
> 

 こんな感じ。
 関数divide-with-date の追加した第二引数を nil にすると、

> (divide-with-date "10月11日芋煮会" nil)
("" "10月11日" "芋煮会")
> 

 日付は、入力のまま出力されます。

 以上、如何でしょうか?