_snippets

This gist entry is meant to store uncategorized trivial code snippets and/or toy-programs.

compact-number-list.lisp

(defun map-plist (fn xs)
  (loop for (p v) on xs by #'cddr collect (funcall fn p v)))

(defun compact (acc x)
  (if (and acc (= x (1+ (car acc))))
      (cons x (cdr acc))
      (list* x x acc)))

(defun compact-number-list (xs)
  (map-plist (lambda (b e) (if (= b e) b (cons b e)))
   (reverse
    (reduce #'compact xs :initial-value '()))))

; CL-USER> (compact-number-list '(1 3 4 5 6 12 13 15))
; (1 (3 . 6) (12 . 13) 15)

mapcar-mapc-benchmark.lisp

(defvar *result* nil)
(defparameter *inf* (cons 1 nil))

(defun circulate (kons) (rplacd kons kons) nil)
(defun terminate (kons) (rplacd kons nil) nil)
(defun gbc  () #+:sbcl (sb-ext:gc :full t))
(defun init () (setq *result* nil) (gbc))

(defun test (fn max &aux (i 0))
  (flet ((lmd (x)
           (when (<= max (incf i)) (terminate *inf*))
           x))
    (circulate *inf*)
    (setq *result* (funcall fn #'lmd *inf*))))

(defun mapcar-test (max) (init) (time (progn (test #'mapcar max) nil)))
(defun mapc-test   (max) (init) (time (progn (test #'mapc   max) nil)))

#|
CL-USER> (mapcar-test 1000000)
Evaluation took:
  0.039 seconds of real time
  0.038928 seconds of total run time (0.031478 user, 0.007450 system)
  100.00% CPU
  77,511,796 processor cycles
  15,990,784 bytes consed

NIL
CL-USER> (mapc-test 1000000)
Evaluation took:
  0.022 seconds of real time
  0.022283 seconds of total run time (0.022029 user, 0.000254 system)
  100.00% CPU
  44,308,343 processor cycles
  0 bytes consed

NIL
|#

sushi.fth

\ the following three lines are development utilities (optional)
\ anew --sushi--
\ : srcfile s" sushi.fth" ;
\ ' srcfile set-srcfile

\ utils
: 2- ( a -- b ) 2 - ;
: 4/ ( a -- b ) 2/ 2/ ;

: under-swap ( a b c -- b a c ) >r swap r> ;
: pos+ ( x1 y1 x2 y2 -- x' y' ) under-swap + >r + r> ;
: pos= ( x1 y1 x2 y2 -- f     ) under-swap = >r = r> and ;

: .hbar   [char] - emit ;
: .vbar   [char] | emit ;
: .corner [char] + emit ;

\ constants and variables
40 constant xdim
11 constant ydim
16 constant buf-size
variable 'head
2variable 'dir
variable 'corner-count

\ ringbuf
create ringbuf buf-size cells 2* allot does> swap buf-size mod cells 2* + ;
: seg   ( seg# -- segadr ) 'head @ + ringbuf ;
: seg0  (      -- segadr ) 0 seg ;
: head@ (      -- x y    ) seg0 2@ ;
: head! ( x y  --        ) seg0 2! ;

\ direction
: left  ( -- dx dy ) -1  0 ;  : right  1  0 ;  : down  0  1 ;  : up  0 -1 ;
: dir@  ( -- dx dy ) 'dir 2@ ;
: dir!  ( dx dy -- ) 'dir 2! ;
: turn-right!  dir@ negate swap dir! ;
: turn-left!   dir@ swap negate dir! ;

\ moving one toward direction
: move-head!  'head @ 1- buf-size mod 'head ! ;
: step!  dir@ head@  pos+  move-head!  head!  ;

\ screen
: corner? ( x y -- f )
    2dup 1        1       ( nw ) pos= if true else
    2dup xdim 1-  1       ( ne ) pos= if true else
    2dup xdim 1-  ydim 1- ( se ) pos= if true else
    2dup 1        ydim 1- ( sw ) pos= if true else
    false
    then then then then
    nip nip ;

: draw-frame { x0 xn y0 yn  -- }  \ this line uses a gforth extension
    x0 y0 at-xy xn x0 do .hbar loop
    yn y0 do x0 i at-xy .vbar xn i at-xy .vbar loop
    x0 yn at-xy xn x0 do .hbar loop
    xn yn  x0 yn  xn y0  x0 y0  4 0 do at-xy .corner loop ;
: draw-iframe  2 xdim 2- 2 ydim 2- draw-frame ;
: draw-eframe  0 xdim    0 ydim    draw-frame ;

: .sushi-char ( i -- ) s" sushi " drop + c@ emit ; \ including trailing space
: draw-sushi   6 0 do i seg 2@ at-xy i .sushi-char loop ;

: corner-count++  1 'corner-count +! ;
: cycle-count ( -- u ) 'corner-count @ 1- 4/ ;
: draw-lap  0 ydim 1+ at-xy ." Lap: " cycle-count 1+ . ;

\ main logic
: sushi-init
    0 'head !  left dir!
    \ initialize (2,1)(3,1)..(6,1), and (7,1) for trailing SPC
    7 1 head!  5 0 do step! loop
    0 'corner-count ! ;

3 value max-count
: sushi-loop
    page draw-iframe draw-eframe
    begin
        draw-sushi draw-lap 50 ms
        step!
        head@ corner? if turn-left! corner-count++ then
    cycle-count max-count >= until ;
: sushi   (     -- ) sushi-init sushi-loop ;
: sushi-n ( cnt -- ) to max-count sushi ;

sushi.lisp

;;;; a study of github.com/henninltn/sushi/blob/master/common-lisp/sushi.lisp

(defun cplx-x  (c) (realpart c))
(defun cplx-y  (c) (imagpart c))
(defun rot90 (vec) (complex (- (cplx-y vec)) (cplx-x vec)))
(defmacro scr-ref  (scr coord) `(aref ,scr (cplx-y ,coord) (cplx-x ,coord)))

(defun init-scr ()
  (let ((rows
          '("+--------------------------------------+"
            "|sushi                                 |"
            "| +----------------------------------+ |"
            "| |                                  | |"
            "| |                                  | |"
            "| |                                  | |"
            "| |                                  | |"
            "| |                                  | |"
            "| +----------------------------------+ |"
            "|                                      |"
            "+--------------------------------------+")))
    (make-array (list 11 40)
                :element-type 'character
                :displaced-to (apply #'concatenate 'string rows))))

(defparameter +corners+  '(#C(1 1) #C(38 1) #C(38 9) #C(1 9)))
(defparameter +init-pos+ '(#C(1 2) #C(1 1) #C(2 1) #C(3 1) #C(4 1) #C(5 1)))
(defparameter +init-vec+ #C(1 0))

(defun next-i-gen ()
  (let ((pos (car (last +init-pos+)))
        (vec +init-vec+))
    (lambda ()
      (setf pos (+ pos vec)
            vec (if (member pos +corners+) (rot90 vec) vec))
      pos)))

(defun redraw-scr (scr)
  (format t "~c[2J" #\escape)   ; clear screen
  (format t "~c[H"  #\escape)   ; goto home
  (destructuring-bind (ydim xdim) (array-dimensions scr)
    (dotimes (y ydim)
      (dotimes (x xdim)
        (princ (aref scr y x)))
      (terpri)))
  (sleep 0.04))

(defun update-scr (scr &rest _zushi)
  (flet ((set-to-scr (p v) (setf (scr-ref scr p) v)))
    (mapc #'set-to-scr _zushi '(#\space #\s #\u #\s #\h #\i))
    (redraw-scr scr)))

(defparameter +cycles+ 90)

(defun convey-zushi-on-belt (&optional (cycles +cycles+))
  (loop with scr = (init-scr)
        with gen = (next-i-gen)
        for   n from 0
        for   (_ z u s h i) = +init-pos+ then (list z u s h i (funcall gen))
        do    (update-scr scr _ z u s h i)
        until (and (plusp n) (zerop (mod n cycles)) (y-or-n-p "Quit?"))))

; (convey-zushi-on-belt)

toy-program.lisp

;;;; FizzBuzz in Common Lisp (using format function)
(defun fizzbuzz (n)
  (flet ((d? (d n) (zerop (mod n d))))
    (loop for i from 1 to n do
      (format t "~:[~:[~a~;buzz~]~;fizz~:[~;buzz~]~] " (d? 3 i) (d? 5 i) i))))

#|
CL-USER> (fizzbuzz 100)
1 2 fizz 4 buzz fizz 7 8 fizz buzz 11 fizz 13 14 fizzbuzz 16 17 fizz 19 buzz fizz 22 23 fizz buzz 26 fizz 28 29 fizzbuzz 31 32 fizz 34 buzz fizz 37 38 fizz buzz 41 fizz 43 44 fizzbuzz 46 47 fizz 49 buzz fizz 52 53 fizz buzz 56 fizz 58 59 fizzbuzz 61 62 fizz 64 buzz fizz 67 68 fizz buzz 71 fizz 73 74 fizzbuzz 76 77 fizz 79 buzz fizz 82 83 fizz buzz 86 fizz 88 89 fizzbuzz 91 92 fizz 94 buzz fizz 97 98 fizz buzz
NIL
CL-USER>
|#

;;;; Zundoko Kiyoshi in Common Lisp (using shiftf)
(defun zundoko (&aux a b c d e)
  (loop
    (shiftf a b c d e (random 2))
    (format t "~:[ズン~;ドコ~] " (zerop e))
    (when (equal (list a b c d e) '(1 1 1 1 0))
      (princ "キ・ヨ・シ!")
      (return))))

#|
CL-USER> (zundoko)
ドコ ドコ ズン ドコ ズン ドコ ズン ズン ドコ ドコ ズン ズン ズン ズン ドコ キ・ヨ・シ!
NIL
CL-USER>
|#

#| 
\ in Forth
: zundoko 0 begin 2* 2 random dup if ." ズン" else ." ドコ" then or 31 and dup 30 = until drop ." キ・ヨ・シ!" ;
|#