Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2010-03-31

KMRCLを眺める(129) BINARY-SEQUENCE-TO-HEX-STRING

| 00:05 | KMRCLを眺める(129) BINARY-SEQUENCE-TO-HEX-STRING - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める(129) BINARY-SEQUENCE-TO-HEX-STRING - わだばLisperになる

今回はKMRCLのstrings.lispから、BINARY-SEQUENCE-TO-HEX-STRINGです。

動作は、

(KL:BINARY-SEQUENCE-TO-HEX-STRING '(255 0 255))
;⇒ "ff00ff"

(KL:BINARY-SEQUENCE-TO-HEX-STRING #(255 0 255))
;⇒ "ff00ff"

というところ

定義は

(defun binary-sequence-to-hex-string (seq)
  (let ((list (etypecase seq
                (list seq)
                (sequence (map 'list #'identity seq)))))
    (string-downcase (format nil "~{~2,'0X~}" list))))

となっていて、

(defun binary-sequence-to-hex-string (seq)
  (format nil "~(~{~2,'0X~}~)" (coerce seq 'list)))

みたいに書いても良いんじゃないのかなと思いましたが、FORMATの、~(~)よりSTRING-DOWNCASEの方が微妙に速く、COERCEよりMAP'LISTの方が微妙に速いようです(SBCL)。

処理系によって微妙に違う結果になるとは思いますが、なるほど。

2010-03-30

KMRCLを眺める(128) CHARHEX

| 00:58 | KMRCLを眺める(128) CHARHEX - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める(128) CHARHEX - わだばLisperになる

今回はKMRCLのstrings.lispから、CHARHEXです。

動作は、

(KL:CHARHEX #\A)
;⇒ 10

というように前回のHEXCHARの逆の関数です。

定義は、

(defconstant* +char-code-lower-a+ (char-code #\a))
(defconstant* +char-code-upper-a+ (char-code #\A))
(defconstant* +char-code-0+ (char-code #\0))
(declaim (type fixnum +char-code-0+ +char-code-upper-a+
               +char-code-0))

(defun charhex (ch)
  "convert hex character to decimal"
  (let ((code (char-code (char-upcase ch))))
    (declare (fixnum ch))
    (if (>= code +char-code-upper-a+)
        (+ 10 (- code +char-code-upper-a+))
        (- code +char-code-0+))))

となっていて、今回は、DEFVARでなくDEFCONSTANT*になっています…

2010-03-28

KMRCLを眺める(127) HEXCHAR

| 23:45 | KMRCLを眺める(127) HEXCHAR - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める(127) HEXCHAR - わだばLisperになる

今回はKMRCLのstrings.lispから、HEXCHARです。

動作は、

(KL:HEXCHAR 10)
;⇒ #\A

というように0〜15を与えると、対応する16進の文字を返してくれるという関数のようです。

定義は、

(defvar +hex-chars+ "0123456789ABCDEF")
(declaim (type simple-string +hex-chars+))

(defun hexchar (n)
  (declare (type (integer 0 15) n))
  (schar +hex-chars+ n))

となっています。

高速に変換したい時に利用するんでしょうか。

以前も疑問に思いましたが、KMRCLでは、定数にしそうなところを、DEFVARで宣言するのはなんで何故なんでしょう。

今回は、+foo+という名前の付け方なので、Typoでしょうか…。

2010-03-27

KMRCLを眺める(126) NON-ALPHANUMERICP

| 22:36 | KMRCLを眺める(126) NON-ALPHANUMERICP - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める(126) NON-ALPHANUMERICP - わだばLisperになる

今回はKMRCLのstrings.lispから、NON-ALPHANUMERICPです。

動作は、

(KL:NON-ALPHANUMERICP #\Space)
;⇒ T

(EVERY #'KL:NON-ALPHANUMERICP "うゐのおくやまけふこえて")
;⇒ NIL

で、CL標準のALPHANUMERICPにNOTをくつけたものです

定義は、そのまま

;;; URL Encoding

(defun non-alphanumericp (ch)
  (not (alphanumericp ch)))

ALPHANUMERICPは、Alphabeticな文字を判定するのですが、数字とA-zのアルファベット+処理系依存の文字が色々という感じです。

2010-03-26

KMRCLを眺める(125) COUNT-STRING-CHAR-IF

| 13:31 | KMRCLを眺める(125) COUNT-STRING-CHAR-IF - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める(125) COUNT-STRING-CHAR-IF - わだばLisperになる

今回はKMRCLのstrings.lispから、COUNT-STRING-CHAR-IFです。

動作は、

(KL:COUNT-STRING-CHAR-IF (LAMBDA (C) (CHAR= #\o C)) "fooooooooooooo")
⇒ 13

というところで、CLの標準に準備されている関数でいえば、COUNT-IFの動きです。

定義は、

(defun count-string-char-if (pred s)
  "Return a count of the number of times a predicate is true
for characters in a string"
  (declare (simple-string s)
           (type (or function symbol) pred)
           (optimize (speed 3) (safety 0) (space 0)))
  (do ((len (length s))
       (i 0 (1+ i))
       (count 0))
      ((= i len) count)
    (declare (fixnum i len count))
    (when (funcall pred (schar s i))
      (incf count))))

という風に前回のCOUNT-STRING-CHARが判定関数を受け取れるようになったものです。

前回に引き続いてわざわざ定義しているからには性能上のメリットでもあるんだろうかということで、速度を測ってみました。

(LOOP :REPEAT 10000000 :DO (COUNT-IF (LAMBDA (C) (CHAR= #\o C)) "fooooooooooooo"))
;⇒ NIL
----------
Evaluation took:
  2.276 seconds of real time
  2.280000 seconds of total run time (2.280000 user, 0.000000 system)
  100.18% CPU
  5,447,862,891 processor cycles
  351,152 bytes consed
  
Intel(R) Core(TM)2 Duo CPU     P8600  @ 2.40GHz

(LOOP :REPEAT 10000000 :DO (KL:COUNT-STRING-CHAR-IF (LAMBDA (C) (CHAR= #\o C)) "fooooooooooooo"))
;⇒ NIL
----------
Evaluation took:
  1.902 seconds of real time
  1.890000 seconds of total run time (1.880000 user, 0.010000 system)
  99.37% CPU
  4,553,261,946 processor cycles
  310,448 bytes consed
  
Intel(R) Core(TM)2 Duo CPU     P8600  @ 2.40GHz

今回は、そんなに違わないようです。もしかしたら、SBCLのCOUNTが遅いんじゃないかとも思えて来ました。

2010-03-25

KMRCLを眺める(124) COUNT-STRING-CHAR

| 13:41 | KMRCLを眺める(124) COUNT-STRING-CHAR - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める(124) COUNT-STRING-CHAR - わだばLisperになる

今回はKMRCLのstrings.lispから、COUNT-STRING-CHARです。

動作は、

(KL:COUNT-STRING-CHAR "fooooooooooooo" #\o)
⇒ 13

というところで、CLの標準に準備されている関数でいえば、COUNTの動きです。

定義は、

(defun count-string-char (s c)
  "Return a count of the number of times a character appears in a string"
  (declare (simple-string s)
           (character c)
           (optimize (speed 3) (safety 0)))
  (do ((len (length s))
       (i 0 (1+ i))
       (count 0))
      ((= i len) count)
    (declare (fixnum i len count))
    (when (char= (schar s i) c)
      (incf count))))

という風にそのものズバリな実装です。

わざわざ定義しているからには性能上のメリットでもあるんだろうかということで、速度を測ってみました。

(LOOP :REPEAT 10000000 :DO (COUNT #\o "fooooooooooooo"))
;⇒ NIL
----------
Evaluation took:
  3.537 seconds of real time
  3.510000 seconds of total run time (3.510000 user, 0.000000 system)
  [ Run times consist of 0.090 seconds GC time, and 3.420 seconds non-GC time. ]
  99.24% CPU
  8,466,477,876 processor cycles
  316,951,616 bytes consed
  
Intel(R) Core(TM)2 Duo CPU     P8600  @ 2.40GHz

(LOOP :REPEAT 10000000 :DO (KL:COUNT-STRING-CHAR "fooooooooooooo" #\o))
;⇒ NIL
----------
Evaluation took:
  0.502 seconds of real time
  0.500000 seconds of total run time (0.500000 user, 0.000000 system)
  99.60% CPU
  1,201,412,826 processor cycles
  63,440 bytes consed
  
Intel(R) Core(TM)2 Duo CPU     P8600  @ 2.40GHz

SBCLだと、ざっと7倍位、KL:COUNT-STRING-CHARの方が速いという結果がでました。

2010-03-24

KMRCLを眺める(123) STRING-STARTS-WITH

| 13:43 | KMRCLを眺める(123) STRING-STARTS-WITH - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める(123) STRING-STARTS-WITH - わだばLisperになる

今回はKMRCLのstrings.lispから、STRING-STARTS-WITHです。

動作は、

(KL:STRING-STARTS-WITH "あめんぼ" "あめんぼあかいなあいうえお")
=> T

というところで、第二引数の文字列が、第一引数の文字列から開始されているかを判定する関数のようです。

定義は、

(defun string-starts-with (start str)
  (and (>= (length str) (length start))
       (string-equal start str :end2 (length start))))

となっています。

2010-03-22

KMRCLを眺める STRING-TO-LIST-SKIP-DELIMITER (122)

| 21:05 | KMRCLを眺める STRING-TO-LIST-SKIP-DELIMITER (122) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める STRING-TO-LIST-SKIP-DELIMITER (122) - わだばLisperになる

今回はKMRCLのstrings.lispから、STRING-TO-LIST-SKIP-DELIMITERです。

動作は、

(KL:STRING-TO-LIST-SKIP-DELIMITER "foo,bar,,,,,,,,baz,,quux" #\,)
⇒ ("foo" "bar" "baz" "quux")

というところ。

定義は、

(defun string-to-list-skip-delimiter (str &optional (delim #\space))
  "Return a list of strings, delimited by spaces, skipping spaces."
  (declare (simple-string str)
           (optimize (speed 0) (space 0) (safety 0)))
  (do* ((results '())
        (end (length str))
        (i (position-not-char delim str 0 end)
           (position-not-char delim str j end))
        (j (when i (position-char delim str i end))
           (when i (position-char delim str i end))))
       ((or (null i) (null j))
        (when (and i (< i end))
          (push (subseq str i end) results))
        (nreverse results))
    (declare (fixnum end)
             (type (or fixnum null) i j))
    (push (subseq str i j) results)))

という風に以前に眺めたPOSITION-CHARとPOSITION-NOT-CHARで文字列の位置を割り出して文字列を切り出すという感じです。

2010-03-21

KMRCLを眺める STRING-DELIMITED-STRING-TO-LIST (121)

| 20:10 | KMRCLを眺める STRING-DELIMITED-STRING-TO-LIST (121) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める STRING-DELIMITED-STRING-TO-LIST (121) - わだばLisperになる

今回はKMRCLのstrings.lispから、STRING-DELIMITED-STRING-TO-LISTです。

動作は、

(MAPCAR #'KL:STRING-TRIM-WHITESPACE 
        (KL:STRING-DELIMITED-STRING-TO-LIST 
         "foo, 
          bar, 
          baz" ","))
⇒ ("foo" "bar" "baz")

というところ。

定義は、

(defun string-delimited-string-to-list (str substr)
  "splits a string delimited by substr into a list of strings"
  (declare (simple-string str substr)
           (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)
                     (debug 0)))
  (do* ((substr-len (length substr))
        (strlen (length str))
        (output '())
        (pos 0)
        (end (fast-string-search substr str substr-len pos strlen)
             (fast-string-search substr str substr-len pos strlen)))
       ((null end)
        (when (< pos strlen)
          (push (subseq str pos) output))
        (nreverse output))
    (declare (fixnum strlen substr-len pos)
             (type (or fixnum null) end))
    (push (subseq str pos end) output)
    (setq pos (+ end substr-len))))

となっていて、前回のFAST-STRING-SEARCHが文字列の切り出しの位置を調べるのに使われています。

2010-03-20

Shibuya.lisp TT#5無事終了!

| 23:28 | Shibuya.lisp TT#5無事終了! - わだばLisperになる を含むブックマーク はてなブックマーク - Shibuya.lisp TT#5無事終了! - わだばLisperになる

大体4ヶ月に1度のペース/年3回のペースで開催していますが、今回5回目を迎えました。

今回はECナビさんのご好意で、懇親会も同じ会場で開催することができました。

懇親会は、立食形式だったのですが、色々移動して色々な方と話ができることもあり、いつもより話が盛り上がっていたようです。

次回TT#6は、7、8月あたりになるかもしれませんが、今のところ全くの未定です。

TT/LT発表者は常に募集していますので、よろしくお願いします!!

KMRCLを眺める FAST-STRING-SEARCH (120)

| 23:04 | KMRCLを眺める FAST-STRING-SEARCH (120) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める FAST-STRING-SEARCH (120) - わだばLisperになる

今回はKMRCLのstrings.lispから、FAST-STRING-SEARCHです。

動作は、

(KL:FAST-STRING-SEARCH "foo" "bazbarfoo" 3 0 9)
⇒ 6

となっていて、名前のとおり最適化されている代わりに色々指定することが多くて使いにくい感じです。

定義は、

(defun fast-string-search (substr str substr-length startpos endpos)
  "Optimized search for a substring in a simple-string"
  (declare (simple-string substr str)
           (fixnum substr-length startpos endpos)
           (optimize (speed 3) (space 0) (safety 0)))
  (do* ((pos startpos (1+ pos))
        (lastpos (- endpos substr-length)))
       ((> pos lastpos) nil)
    (declare (fixnum pos lastpos))
    (do ((i 0 (1+ i)))
        ((= i substr-length)
         (return-from fast-string-search pos))
      (declare (fixnum i))
      (unless (char= (schar str (+ i pos)) (schar substr i))
        (return nil)))))

内側のDOはDOTIMESで良いんじゃないかと思いますが、なにかのこだわりなのかもしれません。

2010-03-19

KMRCLを眺める INTEGER-STRING (119)

| 23:54 | KMRCLを眺める INTEGER-STRING (119) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める INTEGER-STRING (119) - わだばLisperになる

今回はKMRCLのstrings.lispから、INTEGER-STRINGです。

動作は、

(KL:INTEGER-STRING 1234 24)
⇒ "000000000000000000001234"

となっていて、ある数字を指定した長さで、先頭を0でパディングし文字列として返すというものです。

定義は、

(defun integer-string (num len)
  "Outputs a string of LEN digit with an optional initial character PCHAR.
Leading zeros are present."
  (declare (optimize (speed 3) (safety 0) (space 0))
           (type fixnum len)
           (type integer num))
  (do* ((zero-code (char-code #\0))
        (result (make-string len :initial-element #\0))
        (minus? (minusp num))
        (val (if minus? (- 0 num) num)
             (nth-value 0 (floor val 10)))
        (pos (1- len) (1- pos))
        (mod (mod val 10) (mod val 10)))
      ((or (zerop val) (minusp pos))
       (when minus? (setf (schar result 0) #\-))
       result)
    (declare (fixnum mod zero-code pos) (simple-string result) (integer val))
    (setf (schar result pos) (code-char (+ zero-code mod)))))

となっています。

要素が"0"の文字列を作成して、それを上書きして目的のものを作成しています。

2010-03-18

KMRCLを眺める PREFIXED-INTEGER-STRING (118)

| 21:52 | KMRCLを眺める PREFIXED-INTEGER-STRING (118) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める PREFIXED-INTEGER-STRING (118) - わだばLisperになる

今回はKMRCLのstrings.lispから、PREFIXED-INTEGER-STRINGです。

前回はFIXNUMバージョンでしたが、今回は、INTEGERバージョンです。

定義は、

(kl::def-prefixed-number-string prefixed-integer-string integer
 "Outputs a string of LEN digit with an optional initial character PCHAR.
Leading zeros are present. LEN must be an integer.")

となっていて、

(KL:PREFIXED-INTEGER-STRING (EXPT MOST-POSITIVE-FIXNUM 3) #\G 64)
⇒ "G0000000001532495540865888854370663039795561568366082455163109375"

のような動作です。

FIXNUMを越える範囲でも大丈夫。

2010-03-17

KMRCLを眺める PREFIXED-FIXNUM-STRING (117)

| 22:11 | KMRCLを眺める PREFIXED-FIXNUM-STRING (117) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める PREFIXED-FIXNUM-STRING (117) - わだばLisperになる

今回はKMRCLのstrings.lispから、PREFIXED-FIXNUM-STRINGです。

昨日眺めた、DEF-PREFIXED-NUMBER-STRINGで定義された関数です

定義は、

(kl::def-prefixed-number-string prefixed-fixnum-string fixnum
 "Outputs a string of LEN digit with an optional initial character PCHAR.
Leading zeros are present. LEN must be a fixnum.")

となっていて、

(KL::PREFIXED-FIXNUM-STRING MOST-POSITIVE-FIXNUM #\G 24)
⇒ "G000001152921504606846975"

のような動作です。

名前にFIXNUMと入っていますが、(OPTIMIZE (SPEED 3) (SAFETY 0) (SPACE 0))されているので、当たり前かもしれませんが、FIXNUM以外を与えると不定で妙な値を返したりします。

2010-03-16

KMRCLを眺める DEF-PREFIXED-NUMBER-STRING (116)

| 13:52 | KMRCLを眺める DEF-PREFIXED-NUMBER-STRING (116) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める DEF-PREFIXED-NUMBER-STRING (116) - わだばLisperになる

今回はKMRCLのstrings.lispから、DEF-PREFIXED-NUMBER-STRINGです。

動作は、マクロを書くマクロ

(KL::def-prefixed-number-string prefixed-fixnum-string fixnum)

とすると、

(DEFUN PREFIXED-FIXNUM-STRING (NUM PCHAR LEN)
  "Outputs a string of LEN digit with an optional initial character PCHAR.
Leading zeros are present. LEN must be a fixnum."
  (DECLARE (OPTIMIZE (SPEED 3) (SAFETY 0) (SPACE 0))
           (FIXNUM LEN)
           (FIXNUM NUM))
  (WHEN PCHAR (INCF LEN))
  (DO* ((ZERO-CODE (CHAR-CODE #\0))
        (RESULT (MAKE-STRING LEN :INITIAL-ELEMENT #\0))
        (MINUS? (MINUSP NUM))
        (VAL (IF MINUS?
                        (- NUM)
                        NUM)
                    (NTH-VALUE 0 (FLOOR VAL 10)))
        (POS (1- LEN) (1- POS))
        (MOD (MOD VAL 10) (MOD VAL 10)))
       ((OR (ZEROP VAL) (MINUSP POS))
        (WHEN PCHAR (SETF (SCHAR RESULT 0) PCHAR))
        (WHEN MINUS?
          (SETF (SCHAR RESULT
                       (IF PCHAR
                           1
                           0))
                  #\-))
        RESULT)
    (DECLARE (FIXNUM VAL)
             (FIXNUM MOD ZERO-CODE POS)
             (BOOLEAN MINUS?)
             (SIMPLE-STRING RESULT))
    (SETF (SCHAR RESULT POS)
            (CODE-CHAR (THE FIXNUM (+ ZERO-CODE MOD))))))

のようなマクロに展開され、結果として、

(KL::PREFIXED-FIXNUM-STRING 1 #\G 6)
⇒ "G000001"

(KL::PREFIXED-FIXNUM-STRING -1 #\G 6)
⇒"G-00001"

のようなものが定義できるようになります。

定義は、

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defmacro def-prefixed-number-string (fn-name type &optional doc)
    `(defun ,fn-name (num pchar len)
       ,@(when (stringp doc) (list doc))
       (declare (optimize (speed 3) (safety 0) (space 0))
                (fixnum len)
                (,type num))
       (when pchar
         (incf len))
       (do* ((zero-code (char-code #\0))
             (result (make-string len :initial-element #\0))
             (minus? (minusp num))
             (val (if minus? (- num) num)
                  (nth-value 0 (floor val 10)))
             (pos (1- len) (1- pos))
             (mod (mod val 10) (mod val 10)))
            ((or (zerop val) (minusp pos))
             (when pchar
               (setf (schar result 0) pchar))
             (when minus? (setf (schar result (if pchar 1 0)) #\-))
             result)
         (declare (,type val)
                  (fixnum mod zero-code pos)
                  (boolean minus?)
                  (simple-string result))
         (setf (schar result pos) (code-char (the fixnum (+ zero-code mod))))))))

となっています。同じファイル内でこのマクロを利用した定義が続くので、eval-when (:compile-toplevel :load-toplevel :execute)が付いています。

2010-03-15

KMRCLを眺める PRINT-SEPARATED-STRINGS (115)

| 23:36 | KMRCLを眺める PRINT-SEPARATED-STRINGS (115) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める PRINT-SEPARATED-STRINGS (115) - わだばLisperになる

今回はKMRCLのstrings.lispから、PRINT-SEPARATED-STRINGSです。

動作は、

(DEFVAR *STRINGS*
  '(("い" "ろ" "は" "に" "ほ" "へ" "と")
    ("ち" "り" "NULL" "を")
    ("わ" "か" "よ" "た" "れ" "そ")))

(APPLY #'KL:PRINT-SEPARATED-STRINGS *STANDARD-OUTPUT*
       ","
       *STRINGS*))
→ い,ろ,は,に,ほ,へ,と,ち,り,NULL,を,わ,か,よ,た,れ,そ
⇒ #<SB-IMPL::STRING-OUTPUT-STREAM {100D1D8961}>

という風にリストのリストに格納された文字列をセパレータ文字列で区切ってストリームに出力するものです。

定義は、

(defun print-separated-strings (strm separator &rest lists)
  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
                     (compilation-speed 0)))
  (do* ((rest-lists lists (cdr rest-lists))
        (list (car rest-lists) (car rest-lists))
        (last-list (only-null-list-elements-p (cdr rest-lists))
                   (only-null-list-elements-p (cdr rest-lists))))
       ((null rest-lists) strm)
    (do* ((lst list (cdr lst))
          (elem (car lst) (car lst))
          (last-elem (null (cdr lst)) (null (cdr lst))))
         ((null lst))
      (write-string elem strm)
      (unless (and last-elem last-list)
        (write-string separator strm)))))

という風にリストのリストからリストを順に取り出して、中のDO*でリストを回して処理するというものです。

前回眺めたONLY-NULL-LIST-ELEMENTS-Pはこの関数の外側のループで使うことを意図していたようです。

2010-03-14

KMRCLを眺める ONLY-NULL-LIST-ELEMENTS-P (114)

| 22:28 | KMRCLを眺める ONLY-NULL-LIST-ELEMENTS-P (114) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める ONLY-NULL-LIST-ELEMENTS-P (114) - わだばLisperになる

今回はKMRCLのstrings.lispから、ONLY-NULL-LIST-ELEMENTS-Pです。

動作は、名前の通りで

動作は、

(EVERY #'KL::ONLY-NULL-LIST-ELEMENTS-P 
       (MAPCAR #'MAKE-LIST '(0 1 2 3 4 5)))
;⇒ T

となっています。

たまにこういう状況を調べたくなることがあるな、という感じですが、外部にEXPORTはされていない様子。

どうもKMRCLでは、パッケージ内部でしか利用しない関数にも丁寧に名前を付けているように思われます。

定義は、

(defun only-null-list-elements-p (lst)
  (or (null lst) (every #'null lst)))

という風に直球な定義です。

2010-03-13

KMRCLを眺める CONCAT-SEPARATED-STRINGS (113)

| 23:48 | KMRCLを眺める CONCAT-SEPARATED-STRINGS (113) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める CONCAT-SEPARATED-STRINGS (113) - わだばLisperになる

今回はKMRCLのstrings.lispから、CONCAT-SEPARATED-STRINGSです。

名前からするとセパレータで区切られた文字列を出力する様子

動作は、

(KL:CONCAT-SEPARATED-STRINGS ", " 
                             '("foo" "bar" "baz")
                             '("foo" "bar" "baz")
                             '("foo" "bar" "baz"))
⇒ "foo, bar, baz, foo, bar, baz, foo, bar, baz"

定義は、

(defun concat-separated-strings (separator &rest lists)
  (format nil (concatenate 'string "~{~A~^" (string separator) "~}")
          (append-sublists lists)))

となっていて、以前に眺めた、APPEND-SUBLISTSが利用されています。

2010-03-12

KMRCLを眺める STRING-TO-USB8-ARRAY (112)

| 13:36 | KMRCLを眺める STRING-TO-USB8-ARRAY (112) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める STRING-TO-USB8-ARRAY (112) - わだばLisperになる

今回はKMRCLのstrings.lispから、STRING-TO-USB8-ARRAYです。

前回のUSB8-ARRAY-TO-STRINGの逆のことをする関数で、文字列を(UNSIGNED-BYTE 8)のARRAYに変換する関数です。

動作は、

(KL:STRING-TO-USB8-ARRAY "foo")
⇒ #(102 111 111)

というところ

定義は、

(defun string-to-usb8-array (str)
  (declare (simple-string str))
  (let* ((len (length str))
         (vec (make-usb8-array len)))
    (declare (fixnum len)
             (type (simple-array (unsigned-byte 8) (*)) vec)
             (optimize (speed 3)))
    (do ((i 0 (1+ i)))
        ((= i len) vec)
      (declare (fixnum i))
      (setf (aref vec i) (char-code (schar str i))))))

となっています。

2010-03-11

KMRCLを眺める USB8-ARRAY-TO-STRING (111)

| 13:42 | KMRCLを眺める USB8-ARRAY-TO-STRING (111) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める USB8-ARRAY-TO-STRING (111) - わだばLisperになる

今回はKMRCLのstrings.lispから、USB8-ARRAY-TO-STRINGです。

名前の通り、(UNSIGNED-BYTE 8)のARRAYを文字列に変換する関数のようです。

動作は、

(KL:USB8-ARRAY-TO-STRING 
 (MAKE-ARRAY 100
             :INITIAL-ELEMENT (CHAR-CODE #\A)
             :ELEMENT-TYPE '(UNSIGNED-BYTE 8))
 :START 2 :END 12)
⇒ "AAAAAAAAAA"

というところ

定義は、

(defun usb8-array-to-string (vec &key (start 0) end)
  (declare (type (simple-array (unsigned-byte 8) (*)) vec)
           (fixnum start))
  (unless end
    (setq end (length vec)))
  (let* ((len (- end start))
         (str (make-string len)))
    (declare (fixnum len)
             (simple-string str)
             (optimize (speed 3) (safety 0)))
    (do ((i 0 (1+ i)))
        ((= i len) str)
      (declare (fixnum i))
      (setf (schar str i) (code-char (aref vec (the fixnum (+ i start))))))))

となっていて、空の文字列を作成して内容を移しかえています。

(TYPEP (CHAR-CODE #\あ) '(UNSIGNED-BYTE 8))
⇒ NIL

なので、文字が大体ASCIIの範囲の場合に使うのかな、というところです。

2010-03-10

KMRCLを眺める MAKE-USB8-ARRAY (110)

| 13:54 | KMRCLを眺める MAKE-USB8-ARRAY (110) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める MAKE-USB8-ARRAY (110) - わだばLisperになる

今回はKMRCLのstrings.lispから、MAKE-USB8-ARRAYです。

usb8というのは、KMRCLではお馴染の(unsigned-byte 8)の略のようで、動作は、

(KL:MAKE-USB8-ARRAY 10)
⇒ #(0 0 0 0 0 0 0 0 0 0)

です。

定義は、

(defun make-usb8-array (len)
  (make-array len :element-type '(unsigned-byte 8)))

となっていて、典型的な便利関数といったところ。

2010-03-09

KMRCLを眺める ESCAPE-XML-STRING (109)

| 13:44 | KMRCLを眺める ESCAPE-XML-STRING (109) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める ESCAPE-XML-STRING (109) - わだばLisperになる

今回はKMRCLのstrings.lispから、ESCAPE-XML-STRINGです。

動作は、名前からなんとなく想像できますが、

(KL:ESCAPE-XML-STRING "(< x y)")
⇒ "(&lt; x y)"

という感じです。

定義は、

(defun escape-xml-string (string)
  "Escape invalid XML characters"
  (substitute-chars-strings string '((#\& . "&amp;") (#\< . "&lt;"))))

となっています。

SUBSTITUTE-CHARS-STRINGSの使い道がいまいち分かりませんでしたが、ESCAPE-XML-STRINGのようなことをする場合は確かにうまくはまるなと思いました。

2010-03-08

KMRCLを眺める SUBSTITUTE-CHARS-STRINGS (108)

| 14:11 | KMRCLを眺める SUBSTITUTE-CHARS-STRINGS (108) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める SUBSTITUTE-CHARS-STRINGS (108) - わだばLisperになる

今回はKMRCLのstrings.lispから、SUBSTITUTE-CHARS-STRINGSです。

動作は、

(KL:SUBSTITUTE-CHARS-STRINGS "1234567890" '((#\0 . "00")
                                            (#\1 . "11")
                                            (#\2 . "22")
                                            (#\3 . "33")
                                            (#\4 . "44")
                                            (#\5 . "55")
                                            (#\6 . "66")
                                            (#\7 . "77")
                                            (#\8 . "88")
                                            (#\9 . "99")))
⇒ "11223344556677889900"

となっていて、特定の文字を何らかの文字列に置き換えるもののようです。

定義は、

(defun substitute-chars-strings (str repl-alist)
  "Replace all instances of a chars with a string. repl-alist is an assoc
list of characters and replacement strings."
  (declare (simple-string str)
           (optimize (speed 3) (safety 0) (space 0)))
  (do* ((orig-len (length str))
        (new-string (make-string (replaced-string-length str repl-alist)))
        (spos 0 (1+ spos))
        (dpos 0))
      ((>= spos orig-len)
       new-string)
    (declare (fixnum spos dpos) (simple-string new-string))
    (let* ((c (char str spos))
           (match (assoc c repl-alist :test #'char=)))
      (declare (character c))
      (if match
          (let* ((subst (cdr match))
                 (len (length subst)))
            (declare (fixnum len)
                     (simple-string subst))
            (dotimes (j len)
              (declare (fixnum j))
              (setf (char new-string dpos) (char subst j))
              (incf dpos)))
        (progn
          (setf (char new-string dpos) c)
          (incf dpos))))))

となっているのですが、前回眺めたREPLACED-STRING-LENGTHを利用しています。

前回のREPLACED-STRING-LENGTHはいまいち用途が不明でしたが、このSUBSTITUTE-CHARS-STRINGSの補助関数だったようです。なるほど。

しかし、REPLACED-STRING-LENGTHに括り出している処理と同じような処理が、このSUBSTITUTE-CHARS-STRINGSにも含まれていて、なんとなく微妙です。

2010-03-07

KMRCLを眺める REPLACED-STRING-LENGTH (107)

| 20:36 | KMRCLを眺める REPLACED-STRING-LENGTH (107) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める REPLACED-STRING-LENGTH (107) - わだばLisperになる

今回はKMRCLのstrings.lispから、REPLACED-STRING-LENGTHです。

動作は、

(KL::REPLACED-STRING-LENGTH "1234567890" '((#\0 . "00")
                                           (#\1 . "11")
                                           (#\2 . "22")
                                           (#\3 . "33")
                                           (#\4 . "44")
                                           (#\5 . "55")
                                           (#\6 . "66")
                                           (#\7 . "77")
                                           (#\8 . "88")
                                           (#\9 . "99")))
;; (LENGTH "11223344556677889900")
⇒ 20

となっていて、なかなか使いどころが思い浮かびませんが、単一の文字を文字列に置き換えた場合の長さを求めるもののようです。

外部にEXPORTはされていません。

定義は、

(defun replaced-string-length (str repl-alist)
  (declare (simple-string str)
           (optimize (speed 3) (safety 0) (space 0)))
    (do* ((i 0 (1+ i))
          (orig-len (length str))
          (new-len orig-len))
         ((= i orig-len) new-len)
      (declare (fixnum i orig-len new-len))
      (let* ((c (char str i))
             (match (assoc c repl-alist :test #'char=)))
        (declare (character c))
        (when match
          (incf new-len (1- (length
                             (the simple-string (cdr match)))))))))

となっていて、単純に文字列を走査してゆき該当の文字と文字列の対応が与えたALIST中にあれば文字列の長さ分を加えるというもののようです。

2010-03-06

KMRCLを眺める STRING-TRIM-WHITESPACE (106)

| 20:23 | KMRCLを眺める STRING-TRIM-WHITESPACE (106) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める STRING-TRIM-WHITESPACE (106) - わだばLisperになる

今回はKMRCLのstrings.lispから、STRING-TRIM-WHITESPACEです。

前回、前々回に引き続きで、今回は、行頭と行末の空白文字を削除する関数です。

動作は、

(DEFVAR *STRING* (FORMAT NIL "~%foo~%~%~%   "))

*STRING*
⇒ "
foo


   "
(KL:STRING-TRIM-WHITESPACE *STRING*)
;⇒ "foo"

定義は、

(defun string-trim-whitespace (str)
  (string-trim *whitespace-chars* str))

となっています。

このSTRING-TRIM-WHITESPACEのことより、標準でSTRING-TRIMというものが用意されていたことの方に感心してしまいました。

2010-03-05

KMRCLを眺める STRING-LEFT-TRIM-WHITESPACE (105)

| 14:06 | KMRCLを眺める STRING-LEFT-TRIM-WHITESPACE (105) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める STRING-LEFT-TRIM-WHITESPACE (105) - わだばLisperになる

今回はKMRCLのstrings.lispから、STRING-LEFT-TRIM-WHITESPACEです。

前回は、右側(行末)の空白文字の削除でしたが、今回は、逆で、行頭(左側)の空白文字の削除です。

動作は、

(DEFVAR *STRING* (FORMAT NIL "~%~%~%  foo"))

*STRING*
⇒ "


  foo"

(KL:STRING-LEFT-TRIM-WHITESPACE *STRING*)
;⇒ "foo"

定義は、

(defun string-left-trim-whitespace (str)
  (string-left-trim *whitespace-chars* str))

となっています。

2010-03-04

KMRCLを眺める STRING-RIGHT-TRIM-WHITESPACE (104)

| 14:24 | KMRCLを眺める STRING-RIGHT-TRIM-WHITESPACE (104) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める STRING-RIGHT-TRIM-WHITESPACE (104) - わだばLisperになる

今回はKMRCLのstrings.lispから、STRING-RIGHT-TRIM-WHITESPACEです。

動作は、

(DEFVAR *STRING* (FORMAT NIL "foo~%~%~%   "))

*STRING*
⇒ "foo


   "

(KL:STRING-RIGHT-TRIM-WHITESPACE *STRING*)
;⇒ "foo"

ということで、末尾の空白文字を取り除くもののようです。

Perlでいうchompの拡張版という感じでしょうか。

定義は、

(defun string-right-trim-whitespace (str)
  (string-right-trim *whitespace-chars* str))

となっていて、*WHITESPACE-CHARS*を活用しています。

2010-03-03

KMRCLを眺める IS-STRING-WHITESPACE (103)

| 14:14 | KMRCLを眺める IS-STRING-WHITESPACE (103) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める IS-STRING-WHITESPACE (103) - わだばLisperになる

今回はKMRCLのstrings.lispから、IS-STRING-WHITESPACEです。

動作は、

(DEFVAR *STRING*
  (COERCE '(#\Space #\Space #\Space #\Tab #\Return #\Linefeed)
          'STRING))

*STRING*
⇒ "   	
"

(KL:IS-STRING-WHITESPACE *STRING*)
⇒ T

というところで定義は、前回のIS-CHAR-WHITESPACEとEVERYを組合せたものになっています。

(defun is-string-whitespace (str)
  "Return t if string is all whitespace"
  (every #'is-char-whitespace str))

EVERYはシーケンスに対して使えるのでシンプルに書けます。

2010-03-02

KMRCLを眺める IS-CHAR-WHITESPACE (102)

| 14:19 | KMRCLを眺める IS-CHAR-WHITESPACE (102) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める IS-CHAR-WHITESPACE (102) - わだばLisperになる

今回はKMRCLのstrings.lispから、IS-CHAR-WHITESPACEです。

動作は、

(MAP 'LIST #'KL:IS-CHAR-WHITESPACE 
     "    


	")
;⇒ (T T T T T T T T)

というところで定義は、

(defvar *whitespace-chars* '(#\space #\tab #\return #\linefeed
                             #+allegro #\%space
                             #+lispworks #\No-Break-Space))

(defun is-char-whitespace (c)
  (declare (character c) (optimize (speed 3) (safety 0)))
  (or (char= c #\Space) (char= c #\Tab) (char= c #\Return)
      (char= c #\Linefeed)
      #+allegro (char= c #\%space)
      #+lispworks (char= c #\No-Break-Space)))

となっています。

他のライブラリでは、 *WHITESPACE-CHARS* のような物は定数にすることが多い気がしますが、ここでは普通の大域変数になっています。

今回もSBCL等の場合、最適化によって、

(KL:IS-CHAR-WHITESPACE " ")
;⇒ NIL

みたいな動作をします。(safety 0)恐るべし。

2010-03-01

KMRCLを眺める STRING-SUBSTITUTE (101)

| 22:46 | KMRCLを眺める STRING-SUBSTITUTE (101) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める STRING-SUBSTITUTE (101) - わだばLisperになる

今回はKMRCLのstrings.lispから、STRING-SUBSTITUTEです。

動作は、

(KL:STRING-SUBSTITUTE "foofoofoo" "foo" "bar")
;⇒ "barbarbar"

という感じで、Rubyや、Perlでいうgsubになるでしょうか。

定義は、

(defun string-substitute (string substring replacement-string)
  "String substitute by Larry Hunter. Obtained from Google"
  (let ((substring-length (length substring))
        (last-end 0)
        (new-string ""))
    (do ((next-start
          (search substring string)
          (search substring string :start2 last-end)))
        ((null next-start)
         (concatenate 'string new-string (subseq string last-end)))
      (setq new-string
        (concatenate 'string
          new-string
          (subseq string last-end next-start)
          replacement-string))
      (setq last-end (+ next-start substring-length)))))

となっていて、SEARCHで目的の文字列の開始位置を探し、代りになる文字で置き換えつつ繋いで行く感じです。