Archive for the ‘Utility’ Category

command-event で load を楽に

 以前、newLISP 組込関数の構文オンライン表示で使った command-event
 今回は、これを使って、ファイル名だけで lsp ファイルをロードします。

(command-event (fn (s)
  (let (x (read-expr s))
    (let (f (string x))
      (when (and (starts-with f "'") (ends-with f ".lsp"))
        (print "load ")
        (if (file? (1 f)) (load (1 f)) (println (1 f) "\nERR: no file")))))))

 末尾が “.lsp” の時、その lsp ファイルをロードします。
 ただし、ファイル名の先頭には、クォート(’)をつけます。
 使い方は、

C:\Language\newlisp>newlisp -n
newLISP v.10.7.0 32-bit on Windows IPv4/6 UTF-8 libffi, options: newlisp -h

>
(command-event (fn (s)
  (let (x (read-expr s))
    (let (f (string x))
      (when (and (starts-with f "'") (ends-with f ".lsp"))
        (print "load ")
        (if (file? (1 f)) (load (1 f)) (println (1 f) "\nERR: no file")))))))

$command-event
> $command-event
(lambda (s)
 (let (x (read-expr s))
  (let (f (string x))
   (when (and (starts-with f "'") (ends-with f ".lsp"))
    (print "load ")
    (if (file? (1 f))
     (load (1 f))
     (println (1 f) "\nERR: no file"))))))
> jdate
nil
> jdate.lsp
nil
> jdate
nil
> 'jdate.lsp
load jdate.lsp
> jdate
jdate
> (jdate)
"2016/9/28 20:59:45 水"
>

 こんな感じ。もちろん、フルパスも使えます。
 
 jdate については、こちらでどうぞ。
 
 以上、如何でしょうか?

日付関数の日本語化、解説編...または、2038年問題対応?

 今回実装した関数 jdate, jdate:list, jdate:parse, jdate:value, jdate:now の内、list, parse, now は newLISP 組込関数と名前が同じです。通常、組込関数名は変数名にも関数名にも使えませんが、コンテキスト内でコンテキスト名を先付けして

jdate:list, jdate:parse, jdate:now

 とすれば、定義できます。
 また、これらを定義した場合、同名の newLISP 組込関数の呼び出しには、

MAIN:list, MAIN:parse, MAIN:now

 と書く必要もあります。
 それさえ気を付ければ、使いたい変数名や関数名が newLISP 組込関数名と同じだと嘆く必要はありません。まあ、そんなことは、無いでしょうけど(笑)
 この点が今回実装のポイントの一つです。
 さて、日付間の日本語化、前にも実装したことがあります。
 今回、敢えて実装したのは、前述のようにコンテキストにまとめたかったのと、2038年問題にも対応しておこうと思ったからです。
 newLISP は標準ライブラリを使って、あらゆるプラットフォームでの互換性を維持しています。そのため、日付に関する経過秒数を表現する型 time_t は、符号つき 32 ビットで 2038年1月19日3時14分7秒 までしか表現できません。これは、 64 ビット版 newLISP でも同じで、互換性維持のためだと思いますが、敢えて符号つき 32 ビットを使っています。
 だから、これは仕様です。まあ、あと20年はありますから、それまでに解決されるでしょうけど、、、
 それでも、20年くらい先はまだ生きていると思うので、その頃の予定を立てることがあるかもしれません。だから、取り敢えず、符号なし 32 ビット (2106年2月7日6時28分15秒相当)で実装してみました。本来なら、64 ビットで定義すべきですが、2100 年以降の予定なんて考えないから、これで十分かと(笑)
 calcDateValue と gmtime が、そのための関数です。
 一応、

> (jdate:value 2038 1 8)
2146489200
> (jdate:value 2106 2 6)
4294825200
> (jdate:parse "2106.2.6 6:28" "%Y.%m.%d %H:%M")
4294848480
> (jdate:list (jdate:parse "2106.2.6 6:28" "%Y.%m.%d %H:%M"))
(2106 2 6 6 28 0 37 6)
> 

 こんな感じで、使えます。

 以上、如何でしょうか?

追記:
 V10.7.0 の windoows 版で now を実行すると

> (now)
(2016 3 16 8 54 40 297940 76 3 600 -60)
> 

 このように、タイムゾーンのオフセット(分単位)が 600 となります。
 日本では 540 のはずなので、V10.7.0 の windoows 版のバグです。
 この点については Lutz氏 もわかっていて、次回、訂正されるそうです。
 それまで、ご注意を。

日付関数の日本語化

 newLISP の日付関数には、date, date-list, date-parse, date-value, now 等がありますが、date 以外はグリニッジ標準時なので、日本時間で使うには補正が必要です。
 また、date

> (date)
"Tue Mar 15 16:00:19 2016"
> 

 こんな風に、英語表記です。
 そこで、日本語表記、日本時間用の日付関数を定義してみました。

(context 'MAIN:jdate)
(setq YEAR0 1900 EPOCH_YR 1970 SECS_DAY (* 24 60 60))
(define (calcDateValue year month day (hour 0) (int-min 0) (sec 0))
; Algorithm quoting from newLISP source.
  (let (dateValue)
    (setq dateValue (+ (* 367 year) (- (/ (* 7 (+ year (/ (+ month 9) 12))) 4)) (/ (* 275 month) 9) day 1721013))
    (setq dateValue (+ (* dateValue 24 3600) (* hour 3600) (* int-min 60) sec -413319296)) 
    (setq dateValue (& dateValue 0xFFFFFFFF))
    (if (>= dateValue 4107596400) (-- dateValue 86400) dateValue)))
(define (leap (y ((now) 0)))
  (if (and (zero? (% y 4))
       (or (zero? (% y 400))
           (not (zero? (% y 100))))) 1 0))
(define (yearsize year) (+ (leap year) 365))
(define _ytab '((31 28 31 30 31 30 31 31 30 31 30 31)(31 29 31 30 31 30 31 31 30 31 30 31)))
(define (gmtime tm)
; Algorithm quoting from common C-library source.
  (letn (year EPOCH_YR
         dayclock (% tm SECS_DAY)
         dayno (/ tm SECS_DAY)
         tm_sec (% dayclock 60)
         tm_min (/ (% dayclock 3600) 60)
         tm_hour (/ dayclock 3600)
         tm_wday (% (+ 4 dayno) 7))
    (while (>= dayno (yearsize year)) 
      (-- dayno (yearsize year))
      (++ year))
    (let (tm_year (- year 0); YEAR0
          tm_yday dayno
          tm_mon 0
          tm_mday 1)
       (while (>= dayno (_ytab (leap year) tm_mon))
         (-- dayno (_ytab (leap year) tm_mon))
         (++ tm_mon))
       (++ tm_mday dayno)
       (list tm_year (++ tm_mon) tm_mday tm_hour tm_min tm_sec (++ tm_yday) tm_wday))))
(define (jdate:now (offset 540) idx)
  (if idx (MAIN:now offset idx) (MAIN:now offset)))
(define (jdate:value)
  (if (args) (- (apply calcDateValue (args)) (* 9 60 60))
    (date-value)))
(define (jdate:list (sec (jdate:value)) idx)
  (letn (offset (* 9 60 60)
         lst (gmtime (+ sec offset)))
    (if idx (idx lst) lst)))
(define (jdate:jdate (value (jdate:value)))
  (let (lst (jdate:list value)
        str (if utf8 '(227 128 63 230 156 136 231 129 171 230 176 180 230 156 168 233 135 145 229 156 159 
 230 151 165)
                     '(129 64 140 142 137 206 144 133 150 216 139 224 147 121 147 250)))
    (append (join (map string (0 3 lst)) "/") " "
            (join (map string (3 3 lst)) ":") " "
            (if utf8 ((* 3 (lst 7)) 3 (pack (dup "b" (length str)) str))
                     ((* 2 (lst 7)) 2 (pack (dup "b" (length str)) str))))))
(define (jdate:parse dateStr formatStr , res)
  (if (= formatStr "%c") (setq formatStr "%m/%d/%y %H:%M:%S"))
  (let (specs (find-all "(%.)" formatStr)
        regStr (replace "(%.)" (replace "." formatStr "\\.") "(.+)" 0)
        months '("" "Jan" "Feb" "Mar" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
        Months '("" "January" "February" "March" "April" "May" "June" 
                 "July" "August" "September" "October" "November" "December")
        dateLst '(1900 1 1 0 0 0))
    (setq res (regex regStr dateStr))
    (when res 
       (setq res (rest (filter string? res)))
       (when (= (length specs) (length res))
          (dolist (i (transpose (MAIN:list specs res)))
             (case (i 0) 
               ("%b" (setf (dateLst 1) (find (i 1) months 1)))
               ("%B" (setf (dateLst 1) (find (i 1) Months 1)))
               ("%d" (setf (dateLst 2) (int (i 1) 0 10)))
               ("%H" (setf (dateLst 3) (int (i 1) 0 10)))
               ("%m" (setf (dateLst 1) (int (i 1) 0 10)))
               ("%M" (setf (dateLst 4) (int (i 1) 0 10)))
               ("%S" (setf (dateLst 5) (int (i 1) 0 10)))
               ("%Y" (setf (dateLst 0) (int (i 1) 0 10)))
               ("%y" (setf (dateLst 0) (int (string "20" (i 1)))))
               (true )))))
  (if-not (find nil dateLst) (apply jdate:value dateLst))))
(context MAIN)

 使える関数は、jdate, jdate:list, jdate:parse, jdate:value, jdate:now で、それぞれ date, date-list, date-parse, date-value, now に対応します。
 使い方は、

> (jdate)
"2016/3/16 17:8:15 火"
> (jdate:list)
(2016 3 16 17 8 23 75 2)
> (jdate:value 2016 3 16)
1458054000
> (jdate:now)
(2016 3 15 17 8 48 630885 75 2 600 -60)
> (jdate:parse "2010.10.18 7:00" "%Y.%m.%d %H:%M")
1287352800
> (jdate:list (jdate:parse "2010.10.18 7:00" "%Y.%m.%d %H:%M"))
(2010 10 18 7 0 0 291 1)
> 

 こんな感じ、解説は次回に、、、

FOOP で DAG する、その2

 前回の FOOP で DAG する は如何だったでしょうか?
 今回は、DAG (Directed acyclic graph)a 地点から b 地点までの経路を検索するスクリプトを追加してみます。
 ということで、コードは、

(define (DAG:search a b (res '()))
  (let (connects (DAG:search-pre b))
    (if (= connects "start") nil
      (dolist (c connects)
        (let (tmp (append (list c) res))
          (if (= (c 0) a) (push tmp DAG:result -1)
            (DAG:search a (c 0) tmp)))))))
(define (DAG:search-a2b a b)
   (setq DAG:result '())
   (DAG:search a b)
   DAG:result)

 何と DAG データの引き渡しらしき箇所がない(笑)、、、FOOP ですから。
 これを前回のスクリプトに追加して実行します。
 使い方は、

> (setq mydag2 (DAG '((a b) (b c) (b d) (b e) (g d) (c e) (d e) (e f))))
(DAG ((a b) (b c) (b d) (b e) (g d) (c e) (d e) (e f)))
> (:search-a2b mydag2 'g 'f)
(((g d) (d e) (e f)))
> (:search-a2b mydag2 'a 'f)
(((a b) (b e) (e f)) ((a b) (b c) (c e) (e f)) ((a b) (b d) (d e) (e f)))
> 

 こんな感じ。

 以上、如何でしょうか?

FOOP で DAG する

 前回の DAG スクリプトは如何だったでしょうか?
 search-XXX なんて関数名は有りがちな名前。そんな時、関数名の衝突を避けるには FOOP(Functional-Object Oriented Programming )なんてもってこい。
 とは言え、newLISP の目玉でもある FOOP を使ってこなかった私。この辺で覚書きでも作っておこうかと、、、
 
 ということで、コードは、

(new Class 'MAIN:DAG)

(define (DAG:DAG lst)
    (list DAG lst))
(define (DAG:nodes)
  (self 1))
(define (DAG:search-pre)
  (letex (_x (args 0))
    (if (find-all '(? _x) (self 1)) $it "start")))
(define (DAG:search-next)
  (letex (_x (args 0))
    (if (find-all '(_x ?) (self 1)) $it "end")))
(define (DAG:search-all)
  (letex (_x (args 0))
    (local (res)
      (dolist (x (self 1))
         (if (match '(? _x) x) (push x res -1)
             (match '(_x ?) x) (push x res -1)))
      res)))

 ポイントは、オブジェクト・データ部分のアクセスが self になること。
 とわかっていても、私には慣れが必要かも。引数の扱いが、、、
 さて、使い方は、

> (set 'mydag (DAG '((a c) (b c) (c d) (c g) (d e) (d f))))
(DAG ((a c) (b c) (c d) (c g) (d e) (d f)))
> (:nodes mydag)
((a c) (b c) (c d) (c g) (d e) (d f))
> (:search-all mydag 'd)
((c d) (d e) (d f))
> (:search-pre mydag 'd)
((c d))
> (:search-next mydag 'd)
((d e) (d f))
> (:search-pre mydag 'a)
"start"
> (:search-next mydag 'g)
"end"
> 

 こんな感じ。

 以上、如何でしょうか?

newLISP で DAG する...または、match な find-all

 DAG (Directed acyclic graph) とは有向非巡回グラフのことらしい。
 といっても、DAG が何かわからずにコードを書いた私。
 きっかけは、newLISP Foram の投稿から。
 これは簡単にコード化はできそうだと思い、書いて投降したのですが、、、
 何か、しっくりこなかったのです。newLISP らしくないというか、、、
 同投稿で rickyboy 氏が findmatch を使っているのを見て、思い出しました。 find-all がリストに対して match になる(第二構文)ことを。

(if (replace nil (map (fn (x) (match '(? _x) x true)) lst)) $it "start")

 なんて、長ったらしいコードは、find-all を使えば、

(if (find-all '(? _x) lst) $it "start")

 ああ、すっきり。
 前にも、こんなことがあったのを思い出し、忘れないよう blog に(笑)
 先に newLISP Foram に投降したコードは、こんな感じに変わります。

(define (search-pre lst)
  (letex (_x (args 0))
    (if (find-all '(? _x) lst) $it "start")))
(define (search-next lst)
  (letex (_x (args 0))
    (if (find-all '(_x ?) lst) $it "end")))
(define (search-all lst)
  (letex (_x (args 0))
    (local (res)
      (dolist (x lst)
         (if (match '(? _x) x) (push x res -1)
             (match '(_x ?) x) (push x res -1)))
      res)))

 ついでに newLISP らしく、ifcond 的な使い方も(笑)

 以上、如何でしょうか?

64ビットWindowsで空きメモリを表示してみる...または、拡張 import の使用

 以前、newLISP で空きメモリも表示したことがありますが、32ビットの頃の話。
 Windows8 を 64ビット にしたので、GlobalMemoryStatus では、正常な値が取れません。GlobalMemoryStatusEx を使う必要があります。
 そこで、拡張importstruct の出番です(笑)。

(import  "kernel32.dll" "GlobalMemoryStatusEx" "long" "void*")
(struct 'MEMORYSTATUSEX "long" "long" "long long" "long long" "long long" "long long" "long long" "long long" "long long")
;(setq ptrEx (append "64" (chop (dup "00" (* 8 8)))))
(setq ptrEx (pack MEMORYSTATUSEX '(64 0 0 0 0 0 0 0 0)))

 こんな感じで GlobalMemoryStatusEx を準備します。
 変数ptrEx の先頭に64を設定している理由は、MEMORYSTATUSEXdwLength に説明があります。要するに入れておけということ。GlobalMemoryStatus では必要ないのですが、、、
 こうしておけば、

(GlobalMemoryStatusEx ptrEx)
(unpack MEMORYSTATUSEX ptrEx)

 の実行で、

(64 15 8254586880 6973407232 9529655296 8148525056 2147352576 2128674816 0)

 こんな風に必要なデータがリストで得られます。簡単、簡単(笑)。
 リストの中身はこちらを参照して下さい。
 ちなみに空きメモリは

((unpack MEMORYSTATUSEX ptrEx) 3)

 です。
 以上如何でしょうか。

P.S.
 開発版の newLISP 10.4.7 に 64-bit Windows の記述があります。
 次の安定版で登場するかも。
 まっ、64ビットWindows8 でも 32ビット版newLISP で間に合ってますけどね(笑)。

newLISPでショートパス名を扱う...Windows専用

 現在のWindowsは平気で長いパス名が使えますが、DOS 時代は、8文字+ピリオド+拡張子3文字の12文字でした。今でも、ショートパス名として使え、コマンド・プロンプトで dir /x と打てば、実際にショートパス名を見ることができます。
 さて、newLISP でショートパス名を取得するには、WINAPI GetShortPathName を使います。
 使い方はこんな感じ、

> (import "kernel32.dll" "GetShortPathNameA")
GetShortPathNameA@770D9CEE
> (setq l_rtnStr 20 rtnStr (dup "\000" (+ 1 l_rtnStr)))
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
> (GetShortPathNameA {c:\Program Files} rtnStr l_rtnStr)
11
> (string rtnStr)
"c:\\PROGRA~1"
> (GetShortPathNameA {c:\temp} rtnStr l_rtnStr)
7
> (string rtnStr)
"c:\\temp"
> rtnStr
"c:\\temp\000A~1\000\000\000\000\000\000\000\000\000\000"
> 

 組込string を使っているのは、"\000" 以降の余分な文字列を除くため。
 さて、これをどんな時に使うかというと、前に紹介した Windows API を使った音楽ファイルを再生するスクリプト
 ここで使っているWinAPI mciSendString は、ファイル名が長すぎるとエラーを起こします。
 そこで、このショートパス名が生きてくるのです。

(define l_shortPath 67)
(define shortPath (dup "\000" (+ 1 l_shortPath))) 
(define (music:open_s m)
  (GetShortPathNameA m shortPath l_shortPath) (setq m (string shortPath))
  (mciSendStringA (string "open \"" m "\" alias" alias-name) 0 0 0))

 前回のスクリプトに、これを追加するだけ。使い方は、こちらを見て下さい。
 music:open の代わりに、music:open_s を使って音楽ファイルを開くだけで、後は一緒です。
 タイトルにある通り、Windows専用です。
 ローカル・ドライブなら問題無いと思いますが、ネットワーク・ドライブの中にはショートパスをサポートしていなものありますので、注意が必要です。

 以上、如何でしょうか?

gs:get-selected-text を使ってみる...または、newlisp-edit.lsp の改良

 よく、エディターなどで文字を選択して文字検索をかけると、選択された文字列が文字検索パネルに表示されます。でも、newLISPの統合開発環境 newLISP-GS では、そうなりません。
 newLISPの GUI にそういう機能がないのかというと、あります。それが gs:get-selected-text。今回は、これを使って newlisp-edit.lsp を改造します。
 gs:get-selected-textgs:text-pane などで選択された文字列を取得する関数です。書式は、

(gs:get-selected-text sym-id [sym-action])

 となり、sym-id には gs:text-pane などのシンボル名が入ります。newlisp-edit.lsp では、こんな感じに記述します。

(gs:get-selected-text currentEdit 'selected-text-handler)

 ここで currentEdit は変数で、文字通り編集中の gs:text-pane のシンボル名が入っています。だから、クォート()が付きません。selected-text-handler は選択された文字列を取得するハンドラーで

(define (selected-text-handler id text)
  (when text
    (gs:set-text 'FindTextField (base64-dec text))))

 と定義します。これを newlisp-edit.lsp の適当な所に追加して、後は前述の gs:get-selected-text 文を必要な所に挿入します。挿入する箇所は、関数 findbutton-handler

(define (findbutton-handler)
	(if findDialogOpen 
		(begin
			(gs:request-focus 'FindTextField)
			(gs:select-text 'FindTextField 0)
			(gs:get-selected-text currentEdit 'selected-text-handler)	; ←ここに追加
			)
		(openFindDialog)
	)
)

 と関数 openFindDialog

(define (openFindDialog)
	(gs:dialog 'FindDialog 'TheEditor "Find text" 460 200 nil nil)
		:
	(set 'findDialogOpen true)
	(gs:get-selected-text currentEdit 'selected-text-handler)	; ←ここに追加
)

 と二箇所。
 この変更した newlisp-edit.lsp を使えば、文字列を選択して検索をかけた時、検索パネルの Find の表示がある gs:text-field に選択した文字列が入ります。
 これで newLISP-GS の作業効率が大幅アップ(笑)。

 以上、如何でしょうか?

newLISP 組込関数の構文表示3...または、command-event の覚え書き

 前回の組込 command-event を使ったインタラクティブ環境のコマンドヘルプを改良しました。
 前回 command-event に使った関数では、文字列から、改行文字を取り除くのに、replaceを使っていました。Windows版では、CR と LF が、Java 上でのインタラクティブ環境(例えば、newLISP-GS のコマンドライン)では、LF が付加されているからです。V10.4.1からは Windows版で改行文字がつかなくなりますが、、、Java 上はそのままのようです。おそらく、Java 環境の仕様でしょう。
 しかし、だからといって、今回は、わざわざreplaceを使う必要もなく、eval-stringを使う必要もなかったのです。
 それは、read-exprを使うというもの。
 最終的なスクリプトの command-event 部分はこうなりました。

(command-event 
  (fn (s)
    (let (x (read-expr s))
      (if (and (symbol? x)(find x syntax:lst))(syntax x)))))

 こんな感じで、すっきり。これなら、オーバーヘッドも気にならない(笑)。
 全スクリプトcommand-help.lsp はこちらからどうぞ

 以上、如何でしょうか?