cl-mongo を series で

cl-mongo を series で

(defun order-kv (order)
  (cond ((null order)
         nil)
        ((atom order)
         (cl-mongo:kv order 1))
        (t
         (apply #'cl-mongo:kv
                (mapcar (lambda (x)
                          (if (atom x)
                              (cl-mongo:kv x 1)
                              (cl-mongo:kv (car x)
                                           (if (eq :desc (cadr x)) -1 1))))
                        order)))))

(series::defS scan-mongo (collection query &key (skip 0) (limit 0) order)
  "scan mongoDB collection."
  (series::fragl
   ;; args
   ((collection) (query) (skip) (limit) (order))
   ;; rets
   ((doc t))
   ;; aux
   ((doc t) (cursor t) (count integer))
   ;; alt
   ()
   ;; prolog
   ((setq count 0)
    (setq cursor (cl-mongo:db.find
                  collection
                  (aif (order-kv order)
                       (cl-mongo:kv (cl-mongo:kv "query" query)
                                    (cl-mongo:kv "orderby" it))
                       query)
                  :skip skip
                  :limit limit)))
   ;; body
   (L
    (setq doc (pop (cadr cursor)))
    (unless doc
      (push nil (cadr cursor))
      (if (zerop (cl-mongo::db.iterator cursor))
          (go series::end)
          (progn
            (incf count (nth 7 (car cursor)))
            (if (and (plusp limit) (<= limit count))
                (go series::end)
                (progn
                  (setq cursor (cl-mongo:db.iter cursor :limit (- limit count)))
                  (pop (cadr cursor))
                  (go L)))))))
   ;; epilog
   ((cl-mongo:db.stop cursor))
   ;; wraprs
   ()
   ;; impure
   nil))

として

(iterate ((doc (scan-mongo "logs.app" (cl-mongo:$> "_id" last-id))))
  (foo doc))

な感じ。

Paiprolog の出番だ

某問題を解こうと思って Paiprolog の出番だ、と思ったがうまく行かなかった。

(ql:quickload  :paiprolog)

(defpackage :dropquest2012
  (:use :cl :paiprolog))

(in-package dropquest2012)

(<-- (member ?item (?item . ?rest)))
(<- (member ?item (?x . ?rest)) (member ?item ?rest))
(<-- (d ?x) (member ?x (0 1 2 3 4 5 6 7 8 9)))

(prolog-collect (?n1 ?n2 ?n3 ?n4 ?n5)
  (d ?n1)
  (d ?n2)
  (d ?n3)
  (d ?n4)
  (d ?n5)
  (is 24 (* ?n1 ?n2))
  (is ?n4 (/ ?n2 2))
  (is 26 (+ ?n1 ?n2 ?n3 ?n4 ?n5))
  (is ?n5 (+ ?n2 ?n3))
  (is (+ ?n4 ?n5) (+ ?n1 ?n3)))
;;=> NIL

でも、こうすると動く。

(prolog-collect (?n1 ?n2 ?n3 ?n4 ?n5)
  (d ?n1)
  (d ?n2)
  (d ?n3)
  (d ?n4)
  (d ?n5)
  (is 24 (* ?n1 ?n2))
  (is ?n4 (/ ?n2 2))
  (is 26 (+ ?n1 ?n2 ?n3 ?n4 ?n5))
  (is ?n5 (+ ?n2 ?n3))
  ;; (is (+ ?n4 ?n5) (+ ?n1 ?n3))
  (is ?x (+ ?n4 ?n5))
  (is ?x (+ ?n1 ?n3)))
;;=> ((6 4 5 2 9))

なんだろうね。

Series でも解きたくて scan-combination を実装した。

(ql:quickload  :info.read-eval-print.series-ext)

(info.read-eval-print.series-ext:sdefpackage :dropquest2012
                                             (:use :cl))

(in-package dropquest2012)

(collect-first
 (choose-if
  (lambda (xs)
    (destructuring-bind (n1 n2 n3 n4 n5) xs
      (and (= (* n1 n2) 24)
           (= n4 (/ n2 2))
           (= (+ n4 n5) (+ n1 n3))
           (= 26 (+ n1 n2 n3 n4 n5))
           (= n5 (+ n2 n3)))))
  (scan-combination 5 (collect (scan-range :upto 9)))))
;;=> ((6 4 5 2 9))

scan-file*

(defun remove-from-keyword-args (args &rest keywords)
  (loop for (a b) on args by #'cddr
        unless (member a keywords :test #'eq)
          append (list a b)))

(series::defS scan-file* (name &rest args-for-open &key (reader #'read-line) &allow-other-keys)
  "like scan-file. accept options for open."
  (series::fragl ((name) (reader) (args-for-open)) ; args
                 ((items t))            ; rets
                 ((items t)             ; aux
                  (lastcons cons (list nil))
                  (lst list))
                 ()                     ; alt
                 ((setq lst lastcons)   ; prolog
                  (with-open-stream (f (apply #'open name :direction
                                              :input (remove-from-keyword-args args-for-open :reader)))
                    (cl:let ((done (list nil)))
                      (loop
                        (cl:let ((item (cl:funcall reader f nil done)))
                          (when (eq item done)
                            (return nil))
                          (setq lastcons (setf (cdr lastcons) (cons item nil)))))))
                  (setq lst (cdr lst)))
                 ((if (null lst) (go series::end)) ; body
                  (setq items (car lst))
                  (setq lst (cdr lst)))
                 ()                     ; epilog
                 ()                     ; wraprs
                 :context)              ; impure
  :optimizer
  (series::apply-literal-frag
   (cl:let ((file (series::new-var 'file)))
     `((((reader))                      ; args
        ((items t))                     ; rets
        ((items t) (done t (list nil))) ; aux
        ()                              ; alt
        ()                              ; prolog
        ((if (eq (setq items (cl:funcall reader ,file nil done)) done) ; body
             (go series::end)))
        ()                              ; epilog
        ((#'(lambda (code)              ; wraprs
              (list 'with-open-file
                    '(,file ,name :direction :input ,@(remove-from-keyword-args args-for-open :reader))
                    code)) :loop))
        :context)                       ; impure
       ,reader))))                      ; これは何?

SERIES の encapsulated

Common Lisp の SERIES with-open-file 等の unwind-protect を使う場合はencapsulated を使うといいらしい？

encapsulated の第二引数で使えるのは SCAN-FN, SCAN-FN-INCLUSIVE, COLLECT-FNのいずれか。

よくわかってない。。。詳細は SERIES に添付の s-doc.txt を参照。

(require :series)
(use-package :series)

(defun scan-file-wrap (file name body)
  `(with-open-file (,file ,name :direction :input) ,body))

(defmacro simple-scan-file (name)
  (let ((file (gensym)))
    `(encapsulated #'(lambda (body)
                       (scan-file-wrap ',file ',name body))
                   (scan-fn t
                            (lambda ()
                              (read ,file nil))
                            (lambda (x)
                              (read ,file nil))
                            #'null))))

(let ((x (simple-scan-file "/tmp/b.txt")))
  (collect-sum (map-fn t (lambda (x) (* x x)) x)))

CL パッケージの最も長いシンボルを SERIES(series:collect-max)で

以前 CL パッケージで中で最も長いシンボルはどれか探すのを SERIES でやろうとした。そのとき series:collect-max の使い方をよく理解してなかった。第1引数に数値のシリーズをとるので、最大長は返せるけど、その最大長を持つシンボルは返せないと思っていた。

でも、第二引数に第一引数と対応するシンボルのシリーズを渡してやるとちゃっとシンボルの方を返してくれた。

この最大のものを返すといのは loop マクロが苦手としているところで、iterate なんかが上手に解決しているところ。SERIES でもきれいに書けてよかった。

(require :series)

(let* ((symbols (series:scan-symbols :cl))
       (lengths (series:map-fn t (lambda (symbol)
                                   (length (symbol-name symbol)))
                               symbols)))
  (series:collect-max lengths symbols))