まぐねしうむ・リボンだいありー

ゆのかわいいよゆの

hack, ひだまり, CommonLisp |

http://blog.bugyo.tk/lyrical/2008/07/_in.html

リリカル☆Lisp 開発日記にひだまりスケッチキター！

まぁニコスクリプトいじったこと無いんでちんぷんかんぷんですけど。

読めば見当はつく。あと実はこのネタ流行ってる？

とにかくゆののAAかわいいよ。

zickもアニメみたらいいよ。

…うわー慣れ慣れしいな俺。

一個前のloopマクロの件。

なんか説明しそうになったけどめんどくさいから止めた。

よくわかんないけどPAIPの写経おいときますね。

(defun make-queue () ;; never print queue!
  (let ((q (cons nil nil)))
    (setf (car q) q)))
(defun enqueue (item q)
  (setf (car q)
        (setf (cdr (car q))
              (cons item nil)))
  q)
(defun queue-contents (q) (cdr q))

(defstruct loop
  (vars nil) (prologue nil) (body nil) (steps nil)
  (epilogue nil) (result nil) (name nil))

(defmacro loop (&rest exps)
  (if (every #'listp exps)
      `(block nil (tagbody loop ,@exps (go loop)))
    (let ((l (make-loop)))
      (parse-loop-body l exps)
      (fill-loop-template l))))

(defun fill-loop-template (l)
  `(let* ,(reverse (loop-vars l))
     (block ,(loop-name l)
       ,@(reverse (loop-prologue l))
       (tagbody
         loop
         ,@(reverse (loop-body l))
         ,@(reverse (loop-steps l))
         (go loop)
         end
         ,@(reverse (loop-epilogue l))
         (return ,(loop-result l))))))

(defun add-body (l exp) (push exp (loop-body l)))
(defun add-test (l test)
  (push `(if ,test (go end)) (loop-body l)))
(defun add-var (l var init &optional (update nil update?))
  (unless (assoc var (loop-vars l))
    (push (list var init) (loop-vars l)))
  (when update?
    (push `(setq ,var ,update) (loop-steps l))))

(defun parse-loop-body (l exps)
  (unless (null exps)
    (parse-loop-body
     l (call-loop-fn l (car exps) (cdr exps)))))
(defun call-loop-fn (l key exps)
  (if (and (symbolp key) (get key 'loop-fn))
      (funcall (get key 'loop-fn) l (car exps) (cdr exps))
    (error "Unknown loop key")))
(defmacro defloop (key args &rest body)
  `(setf (get ',key 'loop-fn)
     ,(cond ((and (symbolp args) (null body))
             `#'(lambda (l x y)
                  (call-loop-fn l ',args (cons x y))))
            ((and (listp args) (= (length args) 2))
             `#'(lambda (,@args -exps-) ,@body -exps-))
            (t `#'(lambda ,args ,@body)))))

(defloop repeat (l times)
  (let ((i (gensym)))
    (add-var l i times `(- ,i 1))
    (add-test l `(<= ,i 0))))
(defloop as for)
(defloop for (l var exps)
  (let ((key (car exps))
        (source (cadr exps))
        (rest (cddr exps)))
    (ecase key
      ((from downfrom upfrom to downto upto by)
       (loop-for-arithmetic l var exps))
      (in (let ((v (gensym)))
            (add-var l v source `(cdr ,v))
            (add-var l var `(car ,v) `(car ,v))
            (add-test l `(null ,v)))
          rest)
      (on (add-var l var source `(cdr ,var))
          (add-test l `(null ,var))
          rest)
      (= (if (eq (car rest) 'then)
             (progn
               (pop rest)
               (add-var l var source (pop rest)))
           (progn
             (add-var l var nil)
             (add-body l `(setq ,var ,source))))
         rest)
      )))
(defun loop-for-arithmetic (l var exps)
  (let ((exp1 0)
        (exp2 nil)
        (exp3 1)
        (down? nil))
    (when (member (car exps) '(from downfrom upfrom))
      (setq exp1 (cadr exps)
            down? (eq (car exps) 'downfrom)
            exps (cddr exps)))
    (when (member (car exps) '(to downto upto))
      (setq exp2 (cadr exps)
          down? (or down? (eq (car exps) 'downto))
          exps (cddr exps)))
    (when (eq (car exps) 'by)
      (setq exp3 (cadr exps)
        exps (cddr exps)))
    (add-var l var exp1
             `(,(if down? '- '+) ,var ,(maybe-temp l exp3)))
    (when exp2
      (add-test l `(,(if down? '< '>) ,var ,(maybe-temp l exp2))))
    exps))
(defun maybe-temp (l exp)
  (if (constantp exp)
      exp
    (let ((temp (gensym)))
      (add-var l temp exp)
      temp)))
(defloop until (l test) (add-test l test))
(defloop while (l test) (add-test l `(not ,test)))
(defloop always (l test)
  (setf (loop-result l) t)
  (add-body l `(if (not ,test) (return nil))))
(defloop never (l test)
  (setf (loop-result l) t)
  (add-body l `(if ,test (return nil))))
(defmacro once-only (vars &rest body)
  (assert (every #'symbolp vars))
  (let ((temps nil))
    (dotimes (i (length vars))
      (push (gensym) temps))
    `(if (every #'side-effect-free-p (list ,@vars))
         (progn ,@body)
       (list 'let
             ,`(list ,@(mapcar #'(lambda (tmp var)
                                   `(list ',tmp ,var))
                         temps vars))
             (let ,(mapcar #'(lambda (var tmp) `(,var ',tmp))
                     vars temps)
               ,@body)))))
(defun side-effect-free-p (exp)
  (or (constantp exp) (atom exp) (eq (car exp) 'function)))
  
(defmacro return-if (test)
  (once-only (test)
             `(if ,test (return ,test))))
(defloop thereis (l test) (add-body l `(return-if ,test)))
(defmacro loop-finish () '(go end))
(defconstant *acc* (gensym))
(defloop collect (l exp)
  (add-var l *acc* '(make-queue))
  (add-body l `(enqueue ,exp ,*acc*))
  (setf (loop-result l) `(queue-contents ,*acc*)))
(defloop nconc (l exp)
  (add-var l *acc* '(make-queue))
  (add-body l `(queue-nconc ,*acc* ,exp))
  (setf (loop-result l) `(queue-contents ,*acc*)))
(defloop append (l exp exps)
  (call-loop-fn l 'nconc `((copy-list ,exp) ,@exps)))
(defloop count (l exp)
  (add-var l *acc* 0)
  (add-body l `(when ,exp (incf ,*acc*)))
  (setf (loop-result l) *acc*))
(defloop sum (l exp)
  (add-var l *acc* 0)
  (add-body l `(incf ,*acc* ,exp))
  (setf (loop-result l) *acc*))
(defloop maximize (l exp)
  (add-var l *acc* nil)
  (add-body l `(setf ,*acc*
                 (if ,*acc*
                     (max ,*acc* ,exp)
                   ,exp)))
  (setf (loop-result l) *acc*))
(defloop minimize (l exp)
  (add-var l *acc* nil)
  (add-body l `(setf ,*acc*
                 (if ,*acc*
                     (min ,*acc* ,exp)
                   ,exp)))
  (setf (loop-result l) *acc*))
(defloop collecting collect)
(defloop nconcing nconc)
(defloop appending append)
(defloop counting count)
(defloop summing sum)
(defloop maximizing maximize)
(defloop minimizing minimize)
(defloop with (l var exps)
  (let ((init nil))
    (when (eq (car exps) '=)
      (setq init (cadr exps)
        exps (cddr exps)))
    (add-var l var init)
    exps))
(defloop when (l test exps)
  (loop-unless l `(not ,(maybe-set-it test exps)) exps))
(defloop unless (l test exps)
  (loop-unless l (maybe-set-it test exps) exps))
(defun find-anywhere (item tree)
  (cond ((eql item tree) tree)
        ((atom tree) nil)
        (t (let ((found (find-anywhere item (car tree))))
             (if found
                 found
               (find-anywhere item (cdr tree)))))))
(defun maybe-set-it (test exps)
  (if (find-anywhere 'it exps)
      `(setq it ,test)
    test))
(defloop if when)
(defun loop-unless (l test exps)
  (let ((label (gensym)))
    (add-var l 'it nil)
    (add-body l `(if ,test (go ,label)))
    (setf exps (call-loop-fn l (car exps) (cdr exps)))
    (if (eq (car exps) 'else)
        (progn
          (let ((label2 (gensym)))
            (add-body l `(go ,label2))
            (add-body l label)
            (setf exps (call-loop-fn l (cadr exps) (cddr exps)))
            (add-body l label2)))
          (add-body l label)))
  exps)
(defloop do (l exp exps)
  (add-body l exp)
  (do () ((symbolp (car exps)) exps)
    (add-body l (pop exps))))
(defloop return (l exp) (add-body l `(return ,exp)))
(defloop initially (l exp exps)
  (push exp (loop-prologue l))
  (do () ((symbolp (car exps)) exps)
    (push (pop exps) (loop-prologue l))))
(defloop finally (l exp exps)
  (push exp (loop-epilogue l))
  (do () ((symbolp (car exps)) exps)
    (push (pop exps) (loop-epilogue l))))
(defloop named (l exp) (setf (loop-name l) exp))

俺俺lispに食わせるためにどっかいじったような気がするけど思い出せないからそのまま放置うｐ。

あぁ分かった、loop定義にloopが使われてたんでこりゃダメだと思って直したんだ。

たぶんその辺。コメントの"never print queue!"も印字系がゴミだからだね。

直したからうｐしてもいいとかいう厨房論理。

ひだまりスケッチ×３６５　＃２

ひだまり, anime |

前回が嘘だったようないつものひだまりスケッチが開幕。

1話とのリンクネタが多かったのは新規参入組への配慮ですかね。

なんか今回はちょっとお鼻が…とまた思ったり。

大家さんが持ってきたチラシは何の意味があったんだろう。伏線？

授業中ケータイをちょっと隠していじってるのがなんともリアルですね。

あとはにゃんことか豆腐とか、原作にあるネタがかわいいです。

なんか次回予告にヒロさんじゃない人が居た気がしたけどスルースルー。

もうDVDのCMが始まってるなあ。

ドラマCDとか各巻ごとにいろいろ付くみたいね＞初回限定版

ゆの in CL (feat. read-macro)

hack, ひだまり, CommonLisp |

ここはひだまりファンとしてはやらずには居られない。

…というか単に休講というか補講日でそもそも来る必要がなかったことが判明したから。

(defvar *face-side* :left)

(defmacro def-face-char (char)
  `(set-macro-character ,char
                        #'(lambda (stream char)
                            `(,(if (eq *face-side* :left)
                                   ',(intern (format nil "LEFT-~a" char))
                                 ',(intern (format nil "RIGHT-~a" char)))
                                ,(read stream t nil t)))))

(def-face-char #\X)
(def-face-char #\/)

(set-macro-character #\_
                     #'(lambda (stream char)
                         (let ((*face-side* :right))
                           (read stream t nil t))))

(set-macro-character #\<
                     #'(lambda (stream char)
                         `(say ,(read-line stream t nil t))))
(defun left-x (arg)
  (format nil "ひだまり~a" arg))
(defun |LEFT-/| (arg)
  (format nil "スケッチ~a" arg))
(defun |RIGHT-/| (arg)
  arg)
(defun right-x (arg)
  (format nil "×~a" arg))
(defun say (arg)
  (format nil "３６５ ~a" arg))

実行例。

CL-USER: X / _ / X < 来週も見てくださいね！
"ひだまりスケッチ×３６５ 来週も見てくださいね！"

こだわり。

• 顔であることを意識したこと。
• ばってんをばってんに対応させたこと。
• タイトル表記は正確に。

以上。

お粗末さまでした。

一応ね、動的リーダを定義できることはアピールしておかないと。

追記：お題を若干勘違いしてたんで修正。

井口誕生日おめ！

radio, 超ラジ |

超ラジGirlsに、もこたんが、キター！

…一番ちゃんと祝ってる件（？）。

お二人は末永くお幸せに。

ゆの in CL　(feat. symbol-macro) 題意を読まずに三行

ひだまり, CommonLisp |

(define-symbol-macro X (format t "ひだまりスケッチ×３６５ 来週も見てくださいね！"))
(define-symbol-macro _ (exit))
X / _ / X < 来週も見てくださいね！

exitは適当な名前に置き換える。

/は予約語なのでスルーして三文字目で処理系を落とす。