Something almost Schemeish in something CLish.
I just wanted to see how much I could bang out in a single night without without referring to any documentation or previous code, and after having not even written anything in Common Lisp in 1.5 or 2 years. If I could have rememberd or bothered to look up more of CL’s standard lib and macros (like… iteration) this probably could have been done in a quarter of the time and space, but that wasn’t the point. Next up would be to implement define and revoke set!’s ability to create vars, making sure they scope correctly, and to add a list of primitives. But it’s time to go home. Maybe I’ll pick it up again tomorrow, maybe I won’t.
;Copyright (c) 2011 Matthew A. Martin (matt.a.martin@gmail.com)
;
;Permission is hereby granted, free of charge, to any person
;obtaining a copy of this software and associated documentation
;files (the "Software"), to deal in the Software without
;restriction, including without limitation the rights to use,
;copy, modify, merge, publish, distribute, sublicense, and/or sell
;copies of the Software, and to permit persons to whom the
;Software is furnished to do so, subject to the following
;conditions:
;
;The above copyright notice and this permission notice shall be
;included in all copies or substantial portions of the Software.
;
;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;OTHER DEALINGS IN THE SOFTWARE.
;;;;
; A scheme-flavored interpreter in a subset of Common Lisp.
(defconstant empty-stack nil)
(defconstant empty-frame nil)
;CL-USER> (frame (list 'a 'b 'c) (list 1 2 3) (frame (list 'd 'e 'f) (list 4 5 6) empty-frame))
;((A . 1) (B . 2) (C . 3) (D . 4) (E . 5) (F . 6))
(defun frame (vars vals frame)
(if (null vars) frame
(cons (cons (first vars) (first vals))
(frame (rest vars) (rest vals) frame))))
;CL-USER> (stack (frame (list 'a 'b 'c) (list 1 2 3) (frame (list 'd 'e 'f) (list 4 5 6) empty-frame)) empty-stack)
;(((A . 1) (B . 2) (C . 3) (D . 4) (E . 5) (F . 6)))
;CL-USER> (stack (frame (list 'a 'b 'c) (list 1 2 3) empty-frame) (stack (frame (list 'd 'e 'f) (list 4 5 6) empty-frame) empty-stack))
;(((A . 1) (B . 2) (C . 3)) ((D . 4) (E . 5) (F . 6)))
(defun stack (frame stack)
(cons frame stack))
;CL-USER> (lookup-frame 'b (frame (list 'a 'b 'c) (list 1 2 3) empty-frame))
;(B . 2)
;CL-USER> (lookup-frame 'd (frame (list 'a 'b 'c) (list 1 2 3) empty-frame))
;NIL
(defun lookup-frame (var frame)
(if (null frame) nil
(if (eq var (first (first frame)))
(first frame)
(lookup-frame var (rest frame)))))
;CL-USER> (lookup 'a (stack (frame (list 'a 'b) (list 1 2) empty-frame) (stack (frame (list 'c) (list 3) empty-frame) empty-stack)))
;(A . 1)
;CL-USER> (lookup 'b (stack (frame (list 'a 'b) (list 1 2) empty-frame) (stack (frame (list 'c) (list 3) empty-frame) empty-stack)))
;(B . 2)
;CL-USER> (lookup 'c (stack (frame (list 'a 'b) (list 1 2) empty-frame) (stack (frame (list 'c) (list 3) empty-frame) empty-stack)))
;(C . 3)
;CL-USER> (lookup 'd (stack (frame (list 'a 'b) (list 1 2) empty-frame) (stack (frame (list 'c) (list 3) empty-frame) empty-stack)))
;NIL
(defun lookup (var stack)
(if (null stack) nil
(let ((varp (lookup-frame var (first stack))))
(if varp varp
(lookup var (rest stack))))))
(defun value (x)
(rest x))
(defun update (var val stack)
(let ((varp (lookup var stack)))
(if varp
(rplacd varp val)
(rplaca stack (frame (list var)
(list val)
(first stack)))))) ; Exploiting (first nil) => nil here
;;; From here on, nothing should care that envs/stacks and frames are lists.
;; Helper for evaluate.
;CL-USER> (defvar tststk (stack (frame (list 'a 'b) (list 1 2) empty-frame) (stack (frame (list 'c) (list 3) empty-frame) empty-stack)))
;TSTSTK
;CL-USER> (lookup-list (list 'a 'b 'c) tststk)
;(1 2 3)
;CL-USER> (lookup-list (list 'a 'b 'd 'c) tststk)
;(1 2 NIL 3)
(defun lookup-list (varlst stack)
(if (null varlst) nil
(cons (let ((varp (lookup (first varlst) stack)))
(if varp (value varp) varp))
(lookup-list (rest varlst) stack))))
;; Helper for evaluate.
(defun constant (x)
(if (or (eq x t) (eq x nil) (numberp x))
t
nil))
;; Helper for evaluate.
;CL-USER> (func '((a b c) foo))
;(FN (A B C) (BEGIN FOO))
(defun func (args)
(list 'fn ; tag
(first args) ; arg names
(cons 'begin ; implicit begin/progn
(rest args)))) ; fn body
;CL-USER> (fn-args (func '((a b c) foo)))
;(A B C)
(defun fn-args (x) (second x))
;CL-USER> (fn-body (func '((a b c) foo)))
;(BEGIN FOO)
(defun fn-body (x) (third x))
;; Helper for evaluate.
(defun eval-list (exps env)
(if (null exps) nil
(cons (evaluate (first exps) env)
(eval-list (rest exps) env))))
;; Helper for applier
(defun primitive? (x)
(eq (first x) 'prim))
;; Helper for applier
(defun func? (x)
(eq (first x) 'fn))
;CL-USER> (evaluate t tststk)
;T
;CL-USER> (evaluate '(if t b (quote bar)) tststk)
;2
;CL-USER> (evaluate '(if nil b (quote foo)) tststk)
;FOO
;CL-USER> (evaluate '(begin 1 2 3 (eq? 2 2)) tststk)
;T
;CL-USER> (evaluate '(set! a 4) tststk)
;(A . 4)
;CL-USER> tststk
;(((A . 4) (B . 2)) ((C . 3)))
;CL-USER> (evaluate '(set! d 4) tststk)
;(((D . 4) (A . 4) (B . 2)) ((C . 3)))
;CL-USER> tststk
;(((D . 4) (A . 4) (B . 2)) ((C . 3)))
;CL-USER> (evaluate '(set! a 5) tststk)
;(A . 5)
;CL-USER> tststk
;(((D . 4) (A . 5) (B . 2)) ((C . 3)))
;CL-USER> (evaluate '(set! a b) tststk)
;(A . 2)
;CL-USER> tststk
;(((D . 4) (A . 2) (B . 2)) ((C . 3)))
;CL-USER> (evaluate '(set! b 5) tststk)
;(B . 5)
;CL-USER> tststk
;(((D . 4) (A . 2) (B . 5)) ((C . 3)))
;CL-USER> (evaluate '(begin (set! foo (lambda (x) x)) (foo 1)) tststk)
;1
;CL-USER> (evaluate '(begin (set! bar (lambda (x) x)) (bar d)) tststk)
;4
;CL-USER> tststk
;(((BAR FN (X) (BEGIN X)) (FOO FN (X) (BEGIN X)) (D . 4) (A . 2) (B . 5)) ((C . 3)))
(defun evaluate (exp env)
(cond
((constant exp) exp)
((symbolp exp) (rest (lookup exp env)))
(t
(let ((fn (first exp))
(args (rest exp)))
(cond
;; Special forms.
((eq fn 'quote) (first args))
((eq fn 'eq?) (eq (evaluate (first args) env) (evaluate (second args) env)))
((eq fn 'if)
(let ((result (evaluate (first args) env)))
(if result
(evaluate (second args) env)
(evaluate (third args) env))))
((eq fn 'lambda) (func args))
((eq fn 'set!) ; or define
(update (first args) (evaluate (second args) env) env))
((eq fn 'begin)
(if (eq 1 (length args))
(evaluate (first args) env)
;; Borrow CL's progn here assuming it's iterative.
(progn (evaluate (first args) env)
(evaluate (cons 'begin (rest args)) env))))
(t (applier (evaluate fn env) (eval-list args env) env))))))) ; strict
(defun applier (fn args env)
(cond
((primitive? fn) (apply (second fn) args))
((func? fn)
(evaluate (fn-body fn)
(stack (frame (fn-args fn) args empty-frame)
env)))
(t barf))) ; Shouldn't get here.
Scheme, Forth, and C
I came across an article entitled Forth Versus C, and I couldn’t help but notice how much of it applies directly to Scheme (and mostly Common Lisp) as well, with only a few changes in terminology. Naturally not the parts involving its dual stack nature and such, but that’s far from the majority (and you could bring up a similar topic anyway, just compare the C stack to call/cc instead).
This bit especially caught my attention, especially in light of another recent post:
Q. But how can a non-programmer even read a program, let alone tell whether it is right?
A. Forth syntax can be learnt in an hour or two. If the top level of the program cannot be read and understood by someone who understands the problem domain, it is wrong and you should change it.
I would also say this would apply to *any* Domain Specific Language. Lisps (and apparently Forth) make constructing DSL’s trivially easy, any many of the pros and cons of such are discussed (in relation to C).
Back on topic though, I think this article neatly describes many of the fundamental differences between Lisp and C just as well as Fortran and C. I highly recommend giving it a read.
A new Lisp forum
briancarper.net writes:
Ten days ago I complained that there were no good Lisp equivalents of ruby-forum or perlmonks. It looks like someone went and made one. What good timing.
You can find it here.
And yes, it has a Scheme subforum along with the expected Common Lisp. And Elisp, Clojure, and Arc subforums, as well as a catch-all Other.
A bit odd that it’s a PHP forum for a Lisp community… who knows, maybe it’s running on Roadsend (which is built upon Bigloo Scheme)?
Regardless, it’s about damn time!
How I feel about Scheme’s performance.
I came across this post written earlier today, How fast is Scheme? Well…. which states:
I don’t know much about Scheme [...] but it seems that the Scheme compilers produce quite sluggish code, at least looking through the grainy, distorted lens that is the Computer Language Benchmarks Game.
That seems to make enough sense to me. For one-off heavily numerical tests, Scheme pretty much sucks. Especially considering that to compile the code it often has to go through C.
He goes on to say:
SBCL comes out very much on top; in general the Gambit programs take two or three times as long to do their job (although I haven’t looked at memory usage). But as far as Scheme compilers go, Gambit seems to be improving things.
With the right declarations, SBCL has been known to outperform straight C as well. Its compiler is really quite something. And (IIRC) it doesn’t have the “handicap” of using C as an intermediate language.
Personally however, I tend to consider C generating Scheme compilers more practical for issues of portability and/or easier FFI than performance. Chicken’s a good example of braindead-easy FFI. And I feel where Gambit really shines is when you need many, many threads. It’ll handle hundreds of thousands of threads in a breeze. Termite is a good example of exploiting its threading capabilities. RScheme does real-time GC. SCSH has replaced every use I’ve had for shell/perl/etc scripts. There’s a decent chance that any random Linux box already has Guile installed. SISC and Kawa leverage Java’s JIT machiery and provide trivially easy Java FFI. Bigloo can compile to Java bytecode as well. MzScheme runs its own JIT compiler by default where it can, and is prefered to its C output. And there’s a JIT option for all the C-generating Scheme’s as well, compile with LLVM instead of GCC. I think it’d be especially interesting to compare MzScheme’s JIT to MzScheme’s C + LLVM. And if you’re going the Scheme->C route for performance reasons, I’d think Stalin to be the obvious Scheme to use, whether with GCC or LLVM depending on its expected run time (assuming there’s even noticeable startup overhead with LLVM, it’s embedded VM is really quite minimal). Many of them have really nice OO systems built in as well
But none of these tests run long enough to let any of the JIT options really shine. Basically, I say throw any of the JIT options into the mix, and make the tests long enough to really let them do their magic.
I very strongly suspect the same holds for Java, having run a Freenet node for quite some time it gets noticeably snappier once the JVM has had a chance to see it run for a while, especially for recent versions of Java. I’d also argue that’s exactly (other than its relatively primitive GC) what makes Java so incredibly horrid for client-side stuff such as applets, you’re loading a JIT compiler and GC you’ll hardly get a chance to even use before you’ve closed the window. But its JIT has been making leaps and bounds lately, as mentioned on Good Math, Bad Math:
About a year later, testing a new JIT for Java, the Java time was down to 0.7 seconds to run the code, plus about 1 second for the JVM to start up. (The startup times for C, C++, and Ocaml weren’t really measurable – they were smaller than the margin of error for the measurements.)
This is from the previous measurement of 1 minute and 20 seconds for Java. As I said before, SISC, Kawa, and Bigloo will happily use the Java VM. Straight C scored 0.8 seconds. OCaml kicked all their asses even before compilation, but that’s not the point here. If you really need every last bit of performance you can get though, OCaml seems to be worth looking into.
So yeah, I’m *very* interested in what the performance possibilities for Scheme really are, if nothing else out of shear curiosity. Maybe I’ll wind up running a few benchmarks of my own at some point, reiterating the tests, say, a hundred or a thousand times each… but in the end, even if this does increase their performance relative to SBCL… you don’t need to use an obscure implementation or do JIT tricks with SBCL in the first place. A lot of people havn’t heard of Stalin or LLVM. A lot of people don’t want to load one language (Java) to run another (Scheme). Although again, I’d question whether MzScheme’s performance is really so bad in the long run.
And I’d question whether it was really worth it in the first place. Fluxus and Impromtu are two obvious examples which come to mind, both heavy graphics/audio livecoding systems, which solve many problems the same way you would in, say, Python. Offload much of the heavy work onto libraries. There’s a PDF floating on the net somewhere about MzScheme controlling an array of telescopes, and of course there’s the US Navy’s Metcast project. SchemDoc, Scheme Elucidator, the LAML they’re both based on that you can just feed any XML DTD into and get a Scheme representation of that XML language in. SCWM and Orion window managers. MetaModeler for dealing with many/large databases. For web stuff there’s TeX2page, SISCweb, BRL, WiLiKi, the Hop framework, HtmlPrag, SXML, it goes on. There’s a lot of uses which don’t demand every last bit of performance from the Scheme implementation, and I’m just not really doing anything that does.
And if I were writing something and came across an annoying bottleneck? I’d likely take the NetBSD approach. Instead of trying to tweak things to run faster (LLVM, Java, implementation-specific declarations, etc…), I’d see if I couldn’t find a fundamentally more efficient algorithm first. Which reminds me, I still want those books.
[update] On the Reddit thread where apparently most of the views for this article are coming from (who’d have thought so many people would be interested in some Scheme noob’s opinions of language performance? Well over 500 hits already, scant hours later), there’s a link to a fascinating email thread discussing the floating point speed of Gambit-C. I have Brad Lucier’s paper printing to read later as I type this. There’s also a reply in the thread by Brad himself, my favorite part of which is the end summary, which is generally similar to the “NetBSD approach” mentioned above. Is there some sort of established term for this idea?
Anyway, I’ll certainly be rethinking my opinions of Gambit-C as “that threading/Termite implementation”.
[update 2] It’s morning, getting close to 1500 views for this post now… searching for r5rs performance on Google this is the 3rd result! I still don’t see why this is drawing so much attention, but as long as it is, have you seen Scheme Now!?
Scheme Now!, also known as Snow, is a repository of Scheme packages that are portable to several popular implementations of Scheme.
Snow is a general framework for developing and distributing portable Scheme packages. Snow comes with a set of core packages that provide portable APIs for practical programming features such as networking, cryptography, data compression, file system access, etc. Snow packages can export procedures, macros and records.
[update 3] 1844 views as I write this on July 1st. Also now the first result on google for the aforementioned search. Wow. o_O
.stumpwmrc 0.7
; -*-lisp-*-
;;; 0.7
;; 2008/02/13
;; Replaced my MusicPD code with Patzy's as it's far more complete.
;; Using external 'unclutter' again.
;; (run-with-timer 5 5 'banish-pointer) became too annoying.
;; A few cleanups, mostly involving variable names.
(in-package :stumpwm)
;; Include Patzy's MPD code.
(load "~/.stumpwm/contrib/mpd.lisp")
;;; Internal variable definitions.
(defparameter *foreground-color* "darkcyan")
(defparameter *background-color* "black")
(defparameter *border-color* *foreground-color*)
(setf *format-time-string-default* "%a %b %e %k:%M")
(setf *mpd-port* 2100)
(setf *mpd-volume-step* 10)
;;; Internal function definitions.
;; Found at:
;; http://en.wikipedia.org/wiki/User:Gwern/.stumpwmrc
(defun cat (&rest strings) "A shortcut for (concatenate 'string foo bar)."
(apply 'concatenate 'string strings))
;;; Theme.
;; Window border colors.
(set-focus-color *foreground-color*)
(set-unfocus-color *background-color*)
;; Input box colors.
(set-fg-color *foreground-color*)
(set-bg-color *background-color*)
(set-border-color *border-color*)
;; Modeline colors.
(setf *mode-line-foreground-color* *foreground-color*)
(setf *mode-line-background-color* *background-color*)
(setf *mode-line-border-color* *border-color*)
;; Background.
(run-shell-command (cat "xsetroot -solid " *background-color*))
;;; Init stuff.
;; Make frames and windows 1-indexed.
;; See: http://lists.gnu.org/archive/html/stumpwm-devel/2006-08/msg00002.html
;; Found at: http://en.wikipedia.org/wiki/User:Gwern/.stumpwmrc
(setf *frame-number-map* "1234567890")
(setf *window-number-map* "1234567890") ; This doesn't actually do anything.
;; Rename the first group to Browse and create the other groups.
;; Found at: http://en.wikipedia.org/wiki/User:Gwern/.stumpwmrc
(setf (group-name (first (screen-groups (current-screen)))) "Browse")
(run-commands "gnewbg Edit" "gnewbg Term" "gnewbg Comms" "gnewbg Misc")
;; Change the prefix key
;; keycode 115 = F20 in ~/.xmodmaprc, 115 being the left "windows" key.
(set-prefix-key (kbd "F20"))
;; Set up X cursor and colors.
(run-shell-command (cat "xsetroot -cursor_name left_ptr -fg " *background-color* ; Cursor body
" -bg " *border-color*)) ; Cursor outline
;; Keep the X cursor out of the way.
(run-shell-command "unclutter -idle 5 -jitter 5 -root")
;; Configure and start the modeline. Colors are handled above.
(setf *mode-line-border-width* 1)
(setf *mode-line-pad-x* 1)
(setf *mode-line-pad-y* 1)
(setf *mode-line-position* :bottom)
(setf *mode-line-timeout* 10) ; Update every 10 seconds if nothing else has triggered it already.
(setf *screen-mode-line-format* (list "((%n %w) (" ; Current group and frames
`(:eval (format-time-string))
") (%m))")) ; Patzy's MPD code.
;; Switch mode-line on only if needed. Found at:
;; http://hcl-club.lu/svn/development/lisp/.stumpwmrc
(if (not (head-mode-line (current-head)))
(toggle-mode-line (current-screen) (current-head)))
;; Found this tidbit browsing the source. Defaults to :ignore
(setf *mouse-focus-policy* :click) ; I'm fucking lame.
;;; Keyboard shortcuts.
;; Fluxbox-style Alt-F# virtual desktop (group in StumpWM-speak) switching. Modified from:
;; http://hcl-club.lu/svn/development/lisp/.stumpwmrc
(dotimes (i 13)
(unless (eq i 0) ; F0 is non-existant and will error.
(define-key *top-map* (kbd (format nil "M-F~a" i)) (format nil "gselect ~a" i))))
;; Applications.
(define-key *root-map* (kbd "b") "exec firefox ")
(define-key *root-map* (kbd "e") "exec xemacs ")
(define-key *root-map* (kbd "c") (cat "exec urxvt -fg " *foreground-color*
" -bg " *background-color*
" -pr " *foreground-color*
" +sb "))
;; Audio controls, uses un-numlocked keypad.
;; Some keys duplicated, not sure which I prefer yet.
(define-key *top-map* (kbd "KP_Up") "mpd-volume-up")
(define-key *top-map* (kbd "KP_Add") "mpd-volume-up") ; Redundant
(define-key *top-map* (kbd "KP_Down") "mpd-volume-down")
(define-key *top-map* (kbd "KP_Subtract") "mpd-volume-down") ; Redundant
(define-key *top-map* (kbd "KP_Left") "mpd-prev")
(define-key *top-map* (kbd "KP_Right") "mpd-next")
(define-key *top-map* (kbd "Num_Lock") "mpd-toggle-pause") ; The light indicates play/pause 
A really cool StumpWM config for MPD
[ Update: Last I checked, this was included with the StumpWM sources under /contrib ]
Alas, it would seem I poorly reinvented a wheel. Piss poorly, compared to this. I was looking at the change history for StumpWM’s Wiki which led me to http://appart.kicks-ass.net/patzy/files/mpd.lisp.
Unlike my extremely primitive couple of functions, this is essentially a complete MPD client that just happens to use StumpWM as its UI, written by someone with obviously far more Lisp experience than I. I reproduce its current contents below:
;;; MPD client & formatters for stumpwm
;;;
;;; Copyright 2007 Morgan Veyret.
;;;
;;; This module is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2, or (at your option)
;;; any later version.
;;;
;;; This module is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this software; see the file COPYING. If not, write to
;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;; Boston, MA 02111-1307 USA
;;;
;;; USAGE:
;;;
;;; Put:
;;;
;;; (load "/path/to/mpd.lisp")
;;;
;;; In your ~/.stumpwmrc
;;;
;;; Then you can use "%m" in your mode line format.
;;; You can also use the various commands defined at the end of the file
;;;
;;; NOTES:
;;; see http://mpd.wikia.com/wiki/Protocol_Reference for full protocol
(in-package :stumpwm)
;;mpd client
(defparameter *mpd-socket* nil)
(defparameter *mpd-server* "localhost")
(defparameter *mpd-port* 6600)
(defun mpd-send (command)
"Send command to stream ending with newline"
(with-mpd-connection
(ext:write-char-sequence
(concatenate 'string command (string #\Newline))
*mpd-socket*)))
(defun mpd-termination-p (str)
(or (mpd-error-p str)
(mpd-ok-p str)))
(defun mpd-error-p (str)
(when (>= (length str) 3)
(equal (subseq str 0 3) "ACK")))
(defun mpd-ok-p (str)
(equal str "OK"))
(defun mpd-tokenize (str)
(let ((pos (position #\: str)))
(list (read-from-string (concatenate 'string
":"
(subseq str 0 pos)))
(subseq str (+ pos 2)))))
(defun assoc-value (name list)
(cadr (assoc name list)))
(defun mpd-receive ()
"Returns a list containing all data sent by mpd."
(with-mpd-connection
(loop for i = (read-line *mpd-socket*)
when (mpd-error-p i)
do (message "Error sent back by mpd: ~a" i)
until (mpd-termination-p i)
collect (mpd-tokenize i))))
(defun mpd-connect ()
"Connect to mpd server"
(setf *mpd-socket*
(handler-case (socket:socket-connect *mpd-port* *mpd-server*
:element-type 'character)
((or system::simple-os-error error)
(err)
(format t "Error connecting to mpd: ~a~%" err))))
(when *mpd-socket*
(read-line *mpd-socket*)))
(defun mpd-disconnect ()
"Disconnect from mpd server"
(with-mpd-connection
(close *mpd-socket*)
(setf *mpd-socket* nil)))
(defun mpd-send-command (cmd)
(mpd-send cmd)
(mpd-receive))
(defmacro with-mpd-connection (&body body)
`(if *mpd-socket*
(handler-case (progn ,@body)
(error (c) (progn
(message "Error with mpd connection: ~a" c)
(setf *mpd-socket* nil))))
(message "Error: not connected to mpd~%")))
;;mpd formatter
(dolist (a '((#\m fmt-mpd-status)))
(push a *screen-mode-line-formatters*))
(defparameter *mpd-current-song* nil)
(defparameter *mpd-status* nil)
(defun mpd-update-current-song ()
(setf *mpd-current-song* (mpd-send-command "currentsong")))
(defun mpd-update-status ()
(setf *mpd-status* (mpd-send-command "status")))
(defun format-mpd-current-song (current-song)
(let ((artist (assoc-value :artist current-song))
(album (assoc-value :album current-song))
(title (assoc-value :title current-song))
(file (assoc-value :file current-song)))
(if (or (null artist)
(null album)
(null title))
(format nil "~a" file)
(format nil "~a (~a): ~a"
artist
album
title))))
(defun format-mpd-status (status)
(let ((mpd-state (assoc-value :state status)))
(cond
((equal mpd-state "play")
(format nil "Playing [~a;~a] (~a%)"
(if (equal (assoc-value :random *mpd-status*)
"0")
"_"
"S")
(if (equal (assoc-value :repeat *mpd-status*)
"0")
"_"
"R")
(assoc-value :volume *mpd-status*)))
((equal mpd-state "pause")
(format nil "Paused [~a;~a]"
(if (equal (assoc-value :random *mpd-status*)
"0")
"_"
"S")
(if (equal (assoc-value :repeat *mpd-status*)
"0")
"_"
"R")))
((equal mpd-state "stop")
(format nil "Stopped [~a;~a]"
(if (equal (assoc-value :random *mpd-status*)
"0")
"_"
"S")
(if (equal (assoc-value :repeat *mpd-status*)
"0")
"_"
"R"))))))
;;FIXME: update status based on last current song time
;;FIXME: this means updating status on commands calls
(defun fmt-mpd-status (ml)
(declare (ignore ml))
(if *mpd-socket*
(with-mpd-connection
(mpd-update-status)
(if (equal "stop" (assoc-value :state *mpd-status*))
(format nil "~a"
(format-mpd-status *mpd-status*))
(progn (mpd-update-current-song)
(format nil "~a: ~a"
(format-mpd-status *mpd-status*)
(format-mpd-current-song *mpd-current-song*)))))
"Not connected"))
;;mpd commands
(defparameter *mpd-volume-step* 5)
(define-stumpwm-command "mpd-select-song-in-playlist" ()
(let ((status (mpd-send-command "status")))
(labels ((pick (options)
(let ((selection
(select-from-menu (current-screen) options
"Play song in playlist"
(if (equal
(assoc-value :state status)
"play")
(parse-integer
(assoc-value :song status))
0))))
(cond
((null selection)
(throw 'stumpwm::error "Abort."))
(t selection)))))
(let* ((response (mpd-send-command "playlistinfo"))
(result (mapcar #'cadr (remove-if (lambda (item)
(not (equal :file
(first item))))
response))))
(let* ((choice (pick result))
(song-number (position choice result)))
(mpd-send-command (format nil "play ~d" song-number)))))))
(define-stumpwm-command "mpd-connect" ()
(message "~a" (mpd-connect)))
(define-stumpwm-command "mpd-disconnect" ()
(mpd-disconnect))
(define-stumpwm-command "mpd-send-command" ((cmd :rest "Send mpd: "))
(mpd-send cmd)
(mpd-receive))
(define-stumpwm-command "mpd-toggle-pause" ()
(let ((status (mpd-send-command "status")))
(cond
((equal (assoc-value :state status)
"play") (mpd-send-command "pause 1"))
((equal (assoc-value :state status)
"pause") (mpd-send-command "pause 0")))))
(define-stumpwm-command "mpd-toggle-random" ()
(let ((status (mpd-send-command "status")))
(cond
((equal (assoc-value :random status) "0") (mpd-send-command "random 1"))
((equal (assoc-value :random status) "1") (mpd-send-command "random 0")))))
(define-stumpwm-command "mpd-toggle-repeat" ()
(let ((status (mpd-send-command "status")))
(cond
((equal (assoc-value :repeat status) "0") (mpd-send-command "repeat 1"))
((equal (assoc-value :repeat status) "1") (mpd-send-command "repeat 0")))))
(define-stumpwm-command "mpd-play" ()
(mpd-send-command "play"))
(define-stumpwm-command "mpd-stop" ()
(mpd-send-command "stop"))
(define-stumpwm-command "mpd-next" ()
(mpd-send-command "next"))
(define-stumpwm-command "mpd-prev" ()
(mpd-send-command "previous"))
(define-stumpwm-command "mpd-set-volume" ((vol :rest "Set volume to: "))
(mpd-send-command (format nil "setvol ~a" vol)))
(define-stumpwm-command "mpd-volume-up" ()
(let* ((status (mpd-send-command "status"))
(vol (read-from-string (assoc-value :volume status))))
(mpd-send-command (format nil "setvol ~a" (+ vol *mpd-volume-step*)))))
(define-stumpwm-command "mpd-volume-down" ()
(let* ((status (mpd-send-command "status"))
(vol (read-from-string (assoc-value :volume status))))
(mpd-send-command (format nil "setvol ~a" (- vol *mpd-volume-step*)))))
(define-stumpwm-command "mpd-clear" ()
(mpd-send-command "clear"))
(define-stumpwm-command "mpd-update" ()
(message "~a" (mpd-send-command "update")))
(define-stumpwm-command "mpd-current-song" ()
(message "~a" (format-mpd-current-song (mpd-send-command "currentsong"))))
(define-stumpwm-command "mpd-playlist" ()
(let* ((response (mpd-send-command "playlistinfo"))
(result (mapcar #'cadr (remove-if (lambda (item)
(not (equal :file
(first item))))
response))))
(if (< (length result) 80)
(message "Current playlist (~a): ~%^7*~{~a~%~}"
(length result)
result)
(message "~a files in playlist" (length result)))))
(define-stumpwm-command "mpd-add-file" ((file :rest "Add file to playlist: "))
(mpd-send-command (format nil "add \"~a\"" file)))
(define-stumpwm-command "mpd-search-and-add-artist"
((what :rest "Search & add artist to playlist: "))
(let* ((response (mpd-send-command (format nil "search artist \"~a\"" what)))
(result (mapcar #'cadr (remove-if (lambda (item)
(not (equal :file
(first item))))
response))))
(loop for i in result
do (mpd-send-command (format nil "add \"~a\"" i)))
(if (< (length result) 80)
(message "Added ~a files: ~%^7*~{~a~%~}"
(length result)
result)
(message "~a files added" (length result)))))
(define-stumpwm-command "mpd-search-artist" ((what :rest "Search artist: "))
(mpd-send-command (format nil "search artist \"~a\"" what)))
(define-stumpwm-command "mpd-search-file" ((what :rest "Search file: "))
(mpd-send-command (format nil "search file \"~a\"" what)))
(define-stumpwm-command "mpd-search-title" ((what :rest "Search title: "))
(mpd-send-command (format nil "search title \"~a\"" what)))
(define-stumpwm-command "mpd-search-album" ((what :rest "Search album: "))
(mpd-send-command (format nil "search album \"~a\"" what)))
(define-stumpwm-command "mpd-search-genre" ((what :rest "Search genre: "))
(mpd-send-command (format nil "search genre \"~a\"" what)))
;;Key map
;;FIXME: maybe some inferior mode would be a good idea (see resize in user.lisp)
(setf *mpd-search-map*
(let ((m (make-sparse-keymap)))
(define-key m (kbd "a") "mpd-search-artist")
(define-key m (kbd "A") "mpd-search-album")
(define-key m (kbd "t") "mpd-search-title")
(define-key m (kbd "f") "mpd-search-file")
(define-key m (kbd "g") "mpd-search-genre")
m))
(setf *mpd-map*
(let ((m (make-sparse-keymap)))
(define-key m (kbd "SPC") "mpd-toggle-pause")
(define-key m (kbd "s") "mpd-toggle-random")
(define-key m (kbd "r") "mpd-toggle-repeat")
(define-key m (kbd "p") "mpd-play")
(define-key m (kbd "o") "mpd-stop")
(define-key m (kbd "m") "mpd-next")
(define-key m (kbd "l") "mpd-prev")
(define-key m (kbd "c") "mpd-clear")
(define-key m (kbd "u") "mpd-update")
(define-key m (kbd "a") "mpd-search-and-add-artist")
(define-key m (kbd "q") "mpd-select-song-in-playlist")
(define-key m (kbd "z") "mpd-playlist")
(define-key m (kbd "v") "mpd-set-volume")
(define-key m (kbd "e") "mpd-volume-up")
(define-key m (kbd "d") "mpd-volume-down")
(define-key m (kbd "S") *mpd-search-map*)
m))
Scheme vs. Common Lisp
Poking around online as I do, I happened to come across this choice quote:
“Most newcomers eventually (and independently) decide the same thing: Scheme is a better language, but Common Lisp is the right choice for production work. CL has more libraries, and the implementations are somewhat more compatible than Scheme implementations, particularly with respect to macros. ” — http://steve-yegge.blogspot.com/2006/04/lisp-is-not-acceptable-lisp.html
It’s disturbing how true that is. That was precisely my conclusion when I was just getting started (which I still am, but anyway…). Any way you look at it, CL reeks of decades of crust, especially if you’ve written a few lines of Scheme. But… how do you open a network socket in scheme? I asked this question in #Scheme on Freenode last night, and this was the reply:
Prael | Does slib or such have anything for network sockets? offby1 | Prael: slib won't, but your favorite scheme probably does (and it's sure to be non-portable).
That just doesn’t work for me. Or most anyone else, I figure. I like to write code for specs, or failing that, at least de-facto standards. In Common Lisp the answer’s pretty simple: (asdf:install ‘sockets-package-of-choosing). I’m not even quite sure what a good one would be, both occasions I’ve had to use sockets other than my simple StumpWM config it was simply a matter of (asdf:install ‘cl-irc) and (asdf:install ‘cl-audioscrobbler).
As it stands, Common Lisp is my “get shit done” language and Scheme is my “fun” language.
And yes, I’m aware that the new R6RS Scheme does have things like libraries. But the new standard as a whole failed to do anything other than turn it into an ugly hack chock full of arbitrarily bolted on shit that completely violates the spirit of Scheme and would only have justification to exist if Common Lisp wasn’t around, and I have no intention of ever using it. Even those that bothered to comment their approval votes often contain phrases such as “compromise” and “good enough” and “not perfect, but…”. I’m sorry but if that’s what I wanted, I already have Common Lisp. I’ll stick to R5RS, thank you.
.stumpwmrc 0.6
; -*-lisp-*- ;;; 0.6 ;; 2008/01/11 ;; Renamed (mpc) to (mpd-command). ;; Wrote that custom (current-song-info), and changed its name to (mpd-info). ;; It uses CL-PPCRE but we don't need to :use it, StumpWM already does. ;; And neither of them are likely portable, though it would be trivial to make them so if anyone cared. ;; Would have done it sooner but I was too busy passing my NREMT-B license exam. (in-package :stumpwm) ;;; Internal variable definitions. (defparameter FOREGROUND-COLOR "green") (defparameter BACKGROUND-COLOR "black") (defparameter BORDER-COLOR FOREGROUND-COLOR) (setf *format-time-string-default* "%a %b %e %k:%M") (defparameter MPD-HOST "127.0.0.1") (defparameter MPD-PORT 2100) (defparameter MPD-PASS "") ;;; Internal function definitions. ;; Found at: ;; http://en.wikipedia.org/wiki/User:Gwern/.stumpwmrc (defun cat (&rest strings) "A shortcut for (concatenate 'string foo bar)." (apply 'concatenate 'string strings)) ;;; My MPD "client". It's pretty clunky, but it works. ;; These are used by mpd-info. (defvar artist-scanner (cl-ppcre:create-scanner "^Artist:\\s(.*)")) (defvar title-scanner (cl-ppcre:create-scanner "^Title:\\s(.*)")) ;; Returns "(Artist - Title)" (defun mpd-info (host port pass) "Return current song information from MPD." (with-open-stream (socket (socket:socket-connect port host)) ; Likely unportable from CLISP. (format socket "password ~a~%" pass) (format socket "currentsong~%") (cat (loop :for line = (read-line socket nil nil) :while line :do (if (cl-ppcre:scan artist-scanner line) (return (subseq (cl-ppcre:scan-to-strings artist-scanner line) 8)))) " - " (loop :for line = (read-line socket nil nil) :while line :do (if (cl-ppcre:scan title-scanner line) (return (subseq (cl-ppcre:scan-to-strings title-scanner line) 7))))))) ;; This sends our vol up/down and prev/next song and pause/unpause commands. (defun mpd-command (host port pass command) "Pass commands to MPD." (with-open-stream (socket (socket:socket-connect port host :timeout 1)) ; Likely unportable from CLISP. (format socket "password ~a~%" pass) (format socket "~a~%" command))) ;;; Theme. ;; Window border colors. (set-focus-color FOREGROUND-COLOR) (set-unfocus-color BACKGROUND-COLOR) ;; Input box colors. (set-fg-color FOREGROUND-COLOR) (set-bg-color BACKGROUND-COLOR) (set-border-color BORDER-COLOR) ;; Modeline colors. (setf *mode-line-foreground-color* FOREGROUND-COLOR) (setf *mode-line-background-color* BACKGROUND-COLOR) (setf *mode-line-border-color* BORDER-COLOR) ;; Background. (run-shell-command (cat "xsetroot -solid " BACKGROUND-COLOR)) ;;; Init stuff. ;; Make frames 1-indexed. ;; See: http://lists.gnu.org/archive/html/stumpwm-devel/2006-08/msg00002.html ;; Found at: http://en.wikipedia.org/wiki/User:Gwern/.stumpwmrc (setf *frame-number-map* "1234567890") ; Still doesn't seem to work. ;; Rename the first group to Browse and create the other groups. ;; Found at: http://en.wikipedia.org/wiki/User:Gwern/.stumpwmrc (setf (group-name (first (screen-groups (current-screen)))) "Browse") (run-commands "gnewbg Edit" "gnewbg Term" "gnewbg Comms" "gnewbg Misc") ;; Change the prefix key ;; keycode 115 = F20 in ~/.xmodmaprc, 115 being the left "windows" key. (set-prefix-key (kbd "F20")) ;; Set up X cursor and colors. (run-shell-command (cat "xsetroot -cursor_name left_ptr -fg " BACKGROUND-COLOR ; Cursor body " -bg " BORDER-COLOR)) ; Cursor outline ;; Keep the X cursor out of the way. Even when I want it. (run-with-timer 5 5 'banish-pointer) ;; Configure and start the modeline. Colors are handled above. (setf *mode-line-border-width* 1) (setf *mode-line-pad-x* 1) (setf *mode-line-pad-y* 1) (setf *mode-line-position* :bottom) (setf *mode-line-timeout* 10) ; Update every 10 seconds if nothing else has triggered it already. (setf *screen-mode-line-format* (list "(%n %w) (" ; Current group and frames `(:eval (format-time-string)) ") (" ; Just a spacer `(:eval (mpd-info MPD-HOST MPD-PORT MPD-PASS)) ; Defined above ")")) ;; Switch mode-line on only if needed. Found at: ;; http://hcl-club.lu/svn/development/lisp/.stumpwmrc (if (not (head-mode-line (current-head))) (toggle-mode-line (current-screen) (current-head))) ;; Found this tidbit browsing the source. Defaults to :ignore (setf *mouse-focus-policy* :click) ; I'm fucking lame. ;;; Keyboard shortcuts. ;; Fluxbox-style Alt-F# virtual desktop (group in StumpWM-speak) switching. Modified from: ;; http://hcl-club.lu/svn/development/lisp/.stumpwmrc (dotimes (i 13) (unless (eq i 0) ; F0 is non-existant and will error. (define-key *top-map* (kbd (format nil "M-F~a" i)) (format nil "gselect ~a" i)))) ;; Applications. (define-key *root-map* (kbd "b") "exec firefox ") (define-key *root-map* (kbd "e") "exec xemacs ") (define-key *root-map* (kbd "c") (cat "exec urxvt -fg " FOREGROUND-COLOR " -bg " BACKGROUND-COLOR " -pr " FOREGROUND-COLOR " +sb ")) ;; Audio controls, uses un-numlocked keypad. ;; Some keys duplicated, not sure which I prefer yet. (define-key *top-map* (kbd "KP_Up") "mpc-volume-up") (define-key *top-map* (kbd "KP_Add") "mpc-volume-up") ; Redundant (define-key *top-map* (kbd "KP_Down") "mpc-volume-down") (define-key *top-map* (kbd "KP_Subtract") "mpc-volume-down") ; Redundant (define-key *top-map* (kbd "KP_Left") "mpc-song-prev") (define-key *top-map* (kbd "KP_Right") "mpc-song-next") (define-key *top-map* (kbd "Num_Lock") "mpc-pause") ; The light indicates play/pause
.stumpwmrc 0.5
; -*-lisp-*-
;;; 0.5
;; 2008/01/09
;; Moved all the audio commands to un-numlocked keypad. Who uses those keys anyway?
;; Don't need the prefix key this way either, much more efficient.
;; Added Fluxbox-style alt-F# virtual desktop (group in StumpWM speak) switch. Modified from:
;; http://hcl-club.lu/svn/development/lisp/.stumpwmrc
;; Replaced call to (mode-line) with something more intelligent. Found at:
;; http://hcl-club.lu/svn/development/lisp/.stumpwmrc
(in-package :stumpwm)
;;; Internal variable definitions.
(defparameter FOREGROUND-COLOR "green")
(defparameter BACKGROUND-COLOR "black")
(defparameter BORDER-COLOR FOREGROUND-COLOR)
(setf *format-time-string-default* "%a %b %e %k:%M")
(defparameter MPD-HOST "127.0.0.1")
(defparameter MPD-PORT 2100)
(defparameter MPD-PASS "")
;;; Internal function definitions.
;; Found at:
;; http://en.wikipedia.org/wiki/User:Gwern/.stumpwmrc
(defun cat (&rest strings) "A shortcut for (concatenate 'string foo bar)."
(apply 'concatenate 'string strings))
;; My MPD "client".
(defun mpc (host port pass command) "Pass commands to MPD."
(with-open-stream (socket (socket:socket-connect port host :timeout 1))
(format socket "password ~a~%" pass)
(format socket "~a~%" command)))
;; To be replaced.
(defun current-song-info () "Return current song information from MPD."
(run-shell-command "mpc | head -n 1 | tr -d '\\n'" t))
;;; Theme.
;; Window border colors.
(set-focus-color FOREGROUND-COLOR)
(set-unfocus-color BACKGROUND-COLOR)
;; Input box colors.
(set-fg-color FOREGROUND-COLOR)
(set-bg-color BACKGROUND-COLOR)
(set-border-color BORDER-COLOR)
;; Modeline colors.
(setf *mode-line-foreground-color* FOREGROUND-COLOR)
(setf *mode-line-background-color* BACKGROUND-COLOR)
(setf *mode-line-border-color* BORDER-COLOR)
;; Background.
(run-shell-command (cat "xsetroot -solid " BACKGROUND-COLOR))
;;; Init stuff.
;; Make frames 1-indexed.
;; See: http://lists.gnu.org/archive/html/stumpwm-devel/2006-08/msg00002.html
;; Found at: http://en.wikipedia.org/wiki/User:Gwern/.stumpwmrc
(setf *frame-number-map* "1234567890") ; Still doesn't seem to work.
;; Rename the first group to Browse and create the other groups.
;; Found at: http://en.wikipedia.org/wiki/User:Gwern/.stumpwmrc
(setf (group-name (first (screen-groups (current-screen)))) "Browse")
(run-commands "gnewbg Edit" "gnewbg Term" "gnewbg Comms" "gnewbg Misc")
;; Change the prefix key
;; keycode 115 = F20 in ~/.xmodmap, 115 being the left "windows" key.
(set-prefix-key (kbd "F20"))
;; Set up X cursor and colors.
(run-shell-command (cat "xsetroot -cursor_name left_ptr -fg " BACKGROUND-COLOR ; Cursor body
" -bg " BORDER-COLOR)) ; Cursor outline
;; Keep the X cursor out of the way.
(run-with-timer 5 5 'banish-pointer)
;; Configure and start the modeline. Colors are handled above.
(setf *mode-line-border-width* 1)
(setf *mode-line-pad-x* 1)
(setf *mode-line-pad-y* 1)
(setf *mode-line-position* :bottom)
(setf *mode-line-timeout* 10) ; Update every 10 seconds if nothing else has triggered it already.
(setf *screen-mode-line-format* (list "(%n %w) (" ; Current group and frames
`(:eval (format-time-string))
") (" ; Just a spacer
`(:eval (current-song-info)) ; Defined above
")"))
;; Switch mode-line on only if needed. Found at:
;; http://hcl-club.lu/svn/development/lisp/.stumpwmrc
(if (not (head-mode-line (current-head)))
(toggle-mode-line (current-screen) (current-head)))
;; Found this tidbit browsing the source. Defaults to :ignore
(setf *mouse-focus-policy* :click) ; I'm fucking lame.
;;; Keyboard shortcuts.
;; Fluxbox-style Alt-F# virtual desktop (group in StumpWM-speak) switching. Modified from:
;; http://hcl-club.lu/svn/development/lisp/.stumpwmrc
(dotimes (i 13)
(unless (eq i 0)
(define-key *top-map* (kbd (format nil "M-F~a" i)) (format nil "gselect ~a" i))))
;; Applications.
(define-key *root-map* (kbd "b") "exec firefox ")
(define-key *root-map* (kbd "e") "exec xemacs ")
(define-key *root-map* (kbd "c") (cat "exec urxvt -fg " FOREGROUND-COLOR
" -bg " BACKGROUND-COLOR
" -pr " FOREGROUND-COLOR
" +sb "))
;; Audio controls, uses un-numlocked keypad.
;; Some keys duplicated, not sure which I prefer yet.
(define-key *top-map* (kbd "KP_Up") "mpc-volume-up")
(define-key *top-map* (kbd "KP_Down") "mpc-volume-down")
(define-key *top-map* (kbd "KP_Add") "mpc-volume-up") ; Redundant
(define-key *top-map* (kbd "KP_Subtract") "mpc-volume-down") ; Redundant
(define-key *top-map* (kbd "KP_Left") "mpc-song-prev")
(define-key *top-map* (kbd "KP_Right") "mpc-song-next")
(define-key *top-map* (kbd "Num_Lock") "mpc-pause") ; The light indicates play/pause
(define-key *top-map* (kbd "KP_Enter") "mpc-status")
(define-key *top-map* (kbd "KP_Insert") "mpc-status") ; Redundant
(define-stumpwm-command "mpc-status" () "Shows current MPD status and song info. MPC's default output."
(run-shell-command "mpc" t))
(define-stumpwm-command "mpc-volume-up" () "Increase MPD playback volume."
(mpc MPD-HOST MPD-PORT MPD-PASS "volume +10"))
(define-stumpwm-command "mpc-volume-down" () "Decrease MPD playback volume."
(mpc MPD-HOST MPD-PORT MPD-PASS "volume -10"))
(define-stumpwm-command "mpc-song-next" () "Switches MPD playback to next song."
(mpc MPD-HOST MPD-PORT MPD-PASS "next"))
(define-stumpwm-command "mpc-song-prev" () "Switches MPD playback to previous song."
(mpc MPD-HOST MPD-PORT MPD-PASS "previous"))
(define-stumpwm-command "mpc-pause" () "Pause/unpause MPD"
(mpc MPD-HOST MPD-PORT MPD-PASS "pause"))
-
Recent
-
Links
-
Archives
- October 2011 (1)
- January 2011 (2)
- August 2010 (5)
- July 2010 (5)
- May 2010 (3)
- March 2010 (10)
- February 2010 (7)
- November 2009 (1)
- October 2009 (1)
- August 2009 (1)
- July 2009 (3)
- April 2009 (2)
-
Categories
-
RSS
Entries RSS
Comments RSS
