Archive for the ‘lisp’ Category
an overly simplified use case
好久不见 : )
I’d like to transform a series of objects. Let these objects be lists.
CL-USER> (defvar *objects* '((1 3) (21 5) (9 3 5))) *OBJECTS* CL-USER>
Now I have a problem. For a particular purpose, I need the product of these nodes to be even (doesn’t really matter why). This is not the case.
CL-USER> (mapcar (lambda (y) (apply #'* y)) *objects*) (3 105 135) CL-USER>
The simplest solution is to cons a 2 to them. These lists don’t contain a 2 in them. 2 is not their member, so I want to add a 2 to them. (I’d like you to feel the excitement. : ) The thing is that these lists cannot contain even numbers, the manager says. At most one. Anyway, I add a two to them.
CL-USER> (defun f (li) (cons 2 li)) F CL-USER> (setf *objects* (mapcar #'f *objects*)) ((2 1 3) (2 21 5) (2 9 3 5)) CL-USER> (mapcar (lambda (y) (apply #'* y)) *objects*) (6 210 270) CL-USER>
Nice. A few days later, a process comes and adds some new elements (*objects* is really a database):
CL-USER> (setf *objects* (append '((4 7) (7 7 7)) *objects*)) ((4 7) (7 7 7) (2 1 3) (2 21 5) (2 9 3 5)) CL-USER> (mapcar (lambda (y) (apply #'* y)) *objects*) (28 343 6 210 270) CL-USER>
I cannot update them with “(setf *objects* (mapcar #’f *objects*))” because some of them already contains a two. The lesson here is that I didn’t really want to add a 2 to these lists. I wanted to ENSURE an INVARIANT, namely that the product is even. If the product is already even, I wouldn’t need to add a 2. I need to write a IDEMPOTENT function which skips elements already transformed (or the ones that don’t need to be transformed), by giving you g(x) = g(g(x)). Obviously it can happen that x = g(x). Let’s see.
CL-USER> (defun g (li) (if (= 0 (mod (apply #'* li) 2)) li (f li))) G CL-USER> (g '(1 3)) (2 1 3) CL-USER> (g *) (2 1 3) CL-USER> (setf *objects* (mapcar #'g *objects*)) ((4 7) (2 7 7 7) (2 1 3) (2 21 5) (2 9 3 5)) CL-USER>
Done.
The key requirements to write a idempotent function which ensures an invariant:
- being able to check for the invariant -> (= 0 (mod (apply #’* li) 2))
- having a process which restores the invariant if it’s broken -> #’f
For me, the first point was a problem. I was up to add a really complicated structure to the objects which was really difficult to check for existence and additionally there were entities already having a really similar structure (to that I was adding).
my first screencast (with key status monitoring)
I’m really confused with these youtube player resolutions.. It looks better @youtube.com…
cl-smtp meets gmail
(cl-smtp:send-email "smtp.gmail.com"
"youraccount@gmail.com"
"destination@email.address"
"subject"
"email-body"
:ssl :tls
:authentication '("youraccount" "yourpassword")
:cc "youraccount@gmail.com")
After installing cl-smtp with clbuild, it just worked out of the box…
autocc with gnus
I used to hack it this way.
(setq gnus-posting-styles
'((".*"
; other values
("CC" "my@email.address.com")
; further values
(address "my@email.address.com"))))
This previous doesn’t work when using wide reply (overwrites the CC field). The clean way is to use a hook running when you hit C-c C-c (message-send or something) and concatenate your address to the end.
(defun my-auto-cc-hook ()
(let* ((add "my@email.address.com")
(old (message-fetch-field "Cc"))
(new (if (not old)
add
(concat old ", " add))))
(message-remove-header "[Cc][Cc]" t)
(message-add-header (concat "Cc: " new))))
(add-hook 'message-header-hook 'my-auto-cc-hook)
add numbers with ucw
Adding two numbers read from the query part of the URI provided (RFC3986 3.4)
(defvar *adder*
(make-instance
'standard-application
:url-prefix "/add/"))
(defentry-point ""
(:application *adder*) ((a "") (b ""))
(let* ((ai (parse-integer a :junk-allowed t))
(bi (parse-integer b :junk-allowed t))
(succ (and ai bi)))
(call 'adder
:p succ
:a (if succ ai a)
:b (if succ bi b))))
(defcomponent adder ()
((a :accessor a :initarg :a)
(b :accessor b :initarg :b)
(p :accessor p :initarg :p)))
(defmethod error-message ((a adder))
(format
nil
"Error parsing both a=~S and b=~S to integers."
(a a)
(b a)))
(defmethod render ((a adder))
(<:html
(<:body
(<:as-html
(<:p
(if (p a)
(<:as-html
(format nil
"Result is: ~A."
(+ (a a) (b a))))
(<:as-html (error-message a))))))))
Behavior through wget:
$ wget "http://127.0.0.1:8080/add/?a=1&b=2" -O p.html -q
$ sed '$a\ ' p.html
<html
><body
><p
>Result is: 3.</p
></body
></html
>
$ wget "http://127.0.0.1:8080/add/?a=1&b=a" -O p.html -q
$ sed '$a\ ' p.html
<html
><body
><p
>Error parsing both a="1" and b="a" to integers.</p
></body
></html
>
$ wget "http://127.0.0.1:8080/add/?b=asdf" -O p.html -q
$ sed '$a\ ' p.html
<html
><body
><p
>Error parsing both a="" and b="asdf" to integers.</p
></body
></html
>
$
hu.dwim.perec tutorial, lisp clos persistency
Let us see a session which demonstrates the possibility of persisting objects into a database and get it back later on by using project hu.dwim.perec (sometimes available on dwim.hu, when the server is up and running). The slots here are of type integer, but there’s a persistence strategy even for type t, when (AFAIK) some kind of internal representation is dumped. To setup a postgresql database for this session, feel free to read further here.
CL-USER> (setf *load-verbose* nil)
NIL
CL-USER> (setf *compile-verbose* nil)
NIL
CL-USER> (asdf:oos 'asdf:load-op :hu.dwim.perec.postgresql :verbose nil)
#<ASDF:LOAD-OP (:VERBOSE NIL) {B2BC6C9}>
CL-USER> (defpackage :ptest
(:use :hu.dwim.common
:hu.dwim.def
:hu.dwim.defclass-star
:hu.dwim.perec
:hu.dwim.rdbms))
#<PACKAGE "PTEST">
CL-USER> (in-package :ptest)
#<PACKAGE "PTEST">
PTEST> (def special-variable
*psql-db*
(make-instance 'postgresql/perec
:generated-transaction-class-name 'transaction
:default-result-type 'vector
:muffle-warnings t
:connection-specification '(:database "perec_db1"
:user-name "perec_user"
:port 5433
:host "localhost"
:password "perec999pass")))
#<POSTGRESQL/PEREC {B4BF189}>
PTEST> (def persistent-class*
some-user-info ()
((userid :type integer)
(some-data :type integer)))
#<PERSISTENT-CLASS SOME-USER-INFO>
PTEST> (make-compiled-query-cache)
#<HASH-TABLE :TEST EQUAL :COUNT 0 {C53BBC1}>
PTEST> (setf hu.dwim.perec::*compiled-query-cache* *)
#<HASH-TABLE :TEST EQUAL :COUNT 0 {C53BBC1}>
PTEST> (setf (hu.dwim.logger:log-level 'hu.dwim.rdbms::rdbms)
hu.dwim.logger:+fatal+
(hu.dwim.logger:log-level 'hu.dwim.rdbms::sql)
hu.dwim.logger:+fatal+)
5
PTEST> (with-database *psql-db*
(with-transaction
(make-instance 'some-user-info :userid 1 :some-data -1)))
#<SOME-USER-INFO :persistent #t 12>
PTEST> (with-database *psql-db*
(with-transaction
(make-instance 'some-user-info :userid 2 :some-data -2)))
#<SOME-USER-INFO :persistent #t 13>
PTEST> (with-database *psql-db*
(with-transaction
(select (o)
(from (o some-user-info))
(where (= 1 (userid-of o))))))
(#<SOME-USER-INFO :persistent #? 12 {B14A2E1}>)
PTEST> (with-database *psql-db*
(with-transaction
(some-data-of (revive-instance (car *)))))
-1
PTEST>
Tables are created automatically in the appropriate database:
perec_db1=# select * from _some_user_info;
_oid | _userid | _some_data
---------+---------+------------
960005 | 1 | -1
1025541 | 2 | -2
(2 rows)
perec_db1=# \d _some_user_info
Table "public._some_user_info"
Column | Type | Modifiers
------------+---------+-----------
_oid | bigint | not null
_userid | numeric |
_some_data | numeric |
Indexes:
"_some_user_info_pkey" PRIMARY KEY, btree (_oid)
perec_db1=#
the (not so) mysterious common lisp loop
A good interview question: what is the value of the following form?
CL-USER> (mapcar #'funcall (loop as i from 1 upto 3 collect (lambda () i))) ???
“The Truth Is Out There” where macroexpand lives.
CL-USER> (macroexpand `(loop for i from 1 upto 3 collect (lambda () i)))
(BLOCK NIL
(LET ((I 1))
(DECLARE (TYPE (AND REAL NUMBER) I))
(SB-LOOP::WITH-LOOP-LIST-COLLECTION-HEAD (#:LOOP-LIST-HEAD-1070
#:LOOP-LIST-TAIL-1071)
(SB-LOOP::LOOP-BODY NIL
(NIL NIL (WHEN (> I '3) (GO SB-LOOP::END-LOOP)) NIL)
((SB-LOOP::LOOP-COLLECT-RPLACD
(#:LOOP-LIST-HEAD-1070 #:LOOP-LIST-TAIL-1071)
(LIST (LAMBDA () I))))
(NIL (SB-LOOP::LOOP-REALLY-DESETQ I (1+ I))
(WHEN (> I '3) (GO SB-LOOP::END-LOOP)) NIL)
((RETURN-FROM NIL
(SB-LOOP::LOOP-COLLECT-ANSWER
#:LOOP-LIST-HEAD-1070)))))))
T
CL-USER>
Therefore i is a variable and different values are bound to it during the loop. This is explained very well here.
The good candidate answers (4 4 4), because it’s clearly stated on previous page, how this type of loop terminates.
Update: obviously the use case resulting (1 2 3) can be solved by catching the loop variable in a closure like this:
CL-USER> (mapcar #'funcall (loop as i from 1 upto 3 collect (let ((ii i)) (lambda () ii)))) (1 2 3) CL-USER>
granting a loan; simplified
Based on the net present value term, in case of regular $R incomes and rate as discount rate:
years - 1
---------
\
\ R
NPV = ) -------------
/ i
/ / \
--------- | 1 + rate |
i = 0 \ /
Due to identical cash flows this is the sum of a geometric series, so can be rewritten into a closed form:
years
/ \
| 1 |
1 - | -------- |
| 1 + rate |
\ /
NPV = R ---------------------
1
1 - --------
1 + rate
Or identically:
1
1 - --------
1 + rate
R = NPV ---------------------
years
/ \
| 1 |
1 - | -------- |
| 1 + rate |
\ /
In case duration of the loan tends to infinity then the required yearly income converges to:
/ \
| 1 |
NPV | 1 - -------- |
| 1 + rate |
\ /
which is
rate
NPV --------
1 + rate
and this means that there’s no loan of USD NPV regarding rate as discount rate, where the required yearly pay back is less then this number, e.g. (NPV = $1000000, rate = 0.03):
% ./lx86cl Welcome to Clozure Common Lisp Version 1.4-r13119 (LinuxX8632)! ? (defun limit (npv rate) (* npv (/ rate (+ 1 rate)))) LIMIT ? (limit 1000000 0.03) 29126.213 ? (defun r (npv rate years) (* npv (/ (- 1 (/ 1 (+ 1 rate))) (- 1 (expt (/ 1 (+ 1 rate)) years))))) R ? (loop as i from 1 upto 50 collect (r 1000000 0.03 i)) (1000000.0 507389.3 343233.47 261191.42 211994.77 179220.95 155831.47 138307.22 124693.086 113816.05 104929.58 97536.03 91290.83 85947.914 81326.79 77292.09 73740.32 70590.97 67780.47 65257.973 62982.297 60919.8 59042.617 57327.58 55755.207 54309.016 52974.95 51740.992 50596.758 49533.246 48542.637 47618.066 46753.5 45943.64 45183.758 44469.687 43797.676 43164.387 42566.824 42002.29 41468.336 40962.766 40483.58 40028.957 39597.234 39186.906 38796.586 38425.0 38070.984 37733.465) ? (with-open-file (s #P"r.dat" :direction :output :if-exists :supersede) (loop as val in * do (format s "~A~%" val))) NIL ? (quit) % echo set term png \; plot \'r.dat\' with lines | gnuplot > r.png
r.png
rebuild cffi foreign bindings
C:\grault>type lib-foo.c
int getone ()
{
return 1;
}
C:\grault>gcc -shared -o lib-foo.dll lib-foo.c
C:\grault>clisp -q -norc -i ..\.clisprc
;; Loading file ..\.clisprc ...
[1]> (setf *load-verbose* nil)
NIL
[2]> (asdf:oos 'asdf:load-op :cffi :verbose nil)
#<ASDF:LOAD-OP (:VERBOSE NIL) #x19C29B55>
[3]> (cffi:load-foreign-library "lib-foo")
#<CFFI::FOREIGN-LIBRARY #x19CCE065>
[4]> (cffi:defcfun "getone" :int)
GETONE
[5]> (getone)
1
[6]> (ext:saveinitmem "foo.mem" :norc t)
Bytes permanently allocated: 92,512
Bytes currently in use: 3,409,664
Bytes available until next GC: 852,166
3409664 ;
852166 ;
92512 ;
38 ;
20303572 ;
2808018
[7]> (quit)
C:\grault>dir/b
foo.mem
lib-foo.c
lib-foo.dll
C:\grault>clisp -q -M foo.mem
[1]> (getone)
WARNING: FFI::FIND-FOREIGN-FUNCTION: no dynamic object named "getone" in library :DEFAULT
*** - FUNCALL: undefined function NIL
The following restarts are available:
USE-VALUE :R1 Input a value to be used instead of (FDEFINITION 'NIL).
RETRY :R2 Retry
STORE-VALUE :R3 Input a new value for (FDEFINITION 'NIL).
ABORT :R4 Abort main loop
Break 1 [2]> :r4
[3]> (cffi:use-foreign-library "lib-foo")
#<CFFI::FOREIGN-LIBRARY #x19FB66AD>
[4]> (getone)
1
[5]> (quit)
C:\grault>
common lisp GUI-application shipment&delivery on windows
First of all, here’s the lisp I’ve used:
% clisp --version | grep -v ^Machine GNU CLISP 2.48 (2009-07-28) (built on stnt067 [192.168.0.1]) Software: GNU C 3.4.5 (mingw-vista special r3) gcc -mno-cygwin -O2 -W -Wswitch -Wcomment -Wpointer-arith -Wimplicit -Wreturn-ty pe -Wmissing-declarations -Wno-sign-compare -Wno-format-nonliteral -O2 -fexpensi ve-optimizations -falign-functions=4 -D_WIN32 -DUNICODE -DDYNAMIC_FFI -I. -lint l -lreadline -ltermcap -lavcall -lcallback -luser32 -lws2_32 -lole32 -loleaut32 -luuid -liconv -lsigsegv SAFETY=0 HEAPCODES STANDARD_HEAPCODES GENERATIONAL_GC SPVW_BLOCKS SPVW_MIXED TRI VIALMAP_MEMORY libsigsegv 2.6 libiconv 1.11 libreadline 5.2 Features: (READLINE REGEXP SYSCALLS I18N LOOP COMPILER CLOS MOP CLISP ANSI-CL COMMON-LISP LISP=CL INTERPRETER SOCKETS GENERIC-STREAMS LOGICAL-PATHNAMES SCREEN FFI GETTEXT UNICODE BASE-CHAR=CHARACTER PC386 WIN32) C Modules: (clisp i18n syscalls regexp readline) Installation directory: C:\Program Files\clisp-2.48\ User language: ENGLISH %
I have also MingW (5.1.6) and MSYS (1.0.1) installed, Witchs Hat icon downloaded, CLisp dlls copied from the base subdirectory under the installation path. This is the development tree in clean form:
% find . ./bootstrapper.cc ./bootstrapper.rc ./clisp-dlls ./clisp-dlls/libiconv-2.dll ./clisp-dlls/libintl-8.dll ./clisp-dlls/readline5.dll ./Makefile ./message.lisp ./witchs-hat.ico %
Under clisp-dlls, there are the mentioned dlls of CLisp. The file message.lisp contains the program you’d like to run (or ship or whatever). Finally, the bootstrapper files are up to provide an exe with company info, icon, copyright, etc. as an entry to the lisp program. The important bit here is that you don’t want a command prompt window popping up before startup.
Let’s see the files:
% cat message.lisp
(use-package "FFI")
(def-call-out messagebox
(:name "MessageBoxA") (:library "user32.dll")
(:arguments (hwnd int) (text c-string) (capt c-string) (type uint))
(:return-type int)
(:language :stdc))
(defun main ()
(messagebox 0 "Your hacking starts... NOW!" "Demo MsgBox" 0)
(quit))
% cat -A Makefile
all:^Imsgbox-app.exe msgbox-app.img$
^Imkdir -p shipment$
^Icp msgbox-app.exe shipment$
^Icp msgbox-app.img shipment$
^Icp clisp-dlls/* shipment$
$
msgbox-app.img:^Imsgbox-app.img.exe$
^Icp $< $@$
$
msgbox-app.img.exe:^Imessage.lisp$
^Iclisp -q -norc -x \$
"(load \"message.lisp\") \$
(ext:saveinitmem #P\"./msgbox-app.img.exe\" \$
:executable t \$
:norc t \$
:init-function #'main)"$
$
bootstrapper.res:^Ibootstrapper.rc witchs-hat.ico$
^Iwindres $< -O coff -o $@$
^I$
msgbox-app.exe:^Ibootstrapper.cc bootstrapper.res$
^Ig++ -mwindows $^ -o $@$
$
clean:$
^Irm -rf msgbox-app.exe bootstrapper.res \$
^Imsgbox-app.img msgbox-app.img.exe shipment$
% cat bootstrapper.rc
ID ICON "witchs-hat.ico"
1 VERSIONINFO
FILEVERSION 1,0,0,0
PRODUCTVERSION 1,0,0,0
BEGIN
BLOCK "StringFileInfo"
BEGIN
BLOCK "080904E4"
BEGIN
VALUE "CompanyName", "MsgBox Products"
VALUE "FileDescription", "Demo MsgBox"
VALUE "FileVersion", "1.0"
VALUE "InternalName", "msgbox-app"
VALUE "LegalCopyright", "Grault"
VALUE "OriginalFilename", "msgbox-app.exe"
VALUE "ProductName", "Demo MsgBox"
VALUE "ProductVersion", "1.0"
END
END
BLOCK "VarFileInfo"
BEGIN
VALUE "Translation", 0x809, 1252
END
END
% cat bootstrapper.cc
#include <windows.h>
int WinMain(HINSTANCE a0, HINSTANCE a1, LPSTR a2, int a3)
{
STARTUPINFO si;
PROCESS_INFORMATION pi;
ZeroMemory(&si,sizeof(STARTUPINFO));
si.cb = sizeof(STARTUPINFO);
CreateProcess("msgbox-app.img", "",
NULL,NULL,TRUE,CREATE_NO_WINDOW,NULL,
NULL,&si,&pi);
// version and company details are in the bootstrapper exe
// it's kinda better to show these e.g. in process explorer
// and image file as a subprocess
// feel free to comment the following line to leave img only
WaitForSingleObject(pi.hProcess, INFINITE);
return 0;
}
%
These are the files, and here are the results of a make:
% make
windres bootstrapper.rc -O coff -o bootstrapper.res
g++ -mwindows bootstrapper.cc bootstrapper.res -o msgbox-app.exe
clisp -q -norc -x \
"(load \"message.lisp\") \
(ext:saveinitmem #P\"./msgbox-app.img.exe\" \
:executable t \
:norc t \
:init-function #'main)"
;; Loading file message.lisp ...
;; Loaded file message.lisp
T
;; Wrote the memory image into .\msgbox-app.img.exe (5,088,157 bytes)
Bytes permanently allocated: 92,512
Bytes currently in use: 2,188,704
Bytes available until next GC: 544,546
2188704 ;
544546 ;
92512 ;
1 ;
52160 ;
156001
cp msgbox-app.img.exe msgbox-app.img
mkdir -p shipment
cp msgbox-app.exe shipment
cp msgbox-app.img shipment
cp clisp-dlls/* shipment
% find
.
./bootstrapper.cc
./bootstrapper.rc
./bootstrapper.res
./clisp-dlls
./clisp-dlls/libiconv-2.dll
./clisp-dlls/libintl-8.dll
./clisp-dlls/readline5.dll
./Makefile
./message.lisp
./msgbox-app.exe
./msgbox-app.img
./msgbox-app.img.exe
./shipment
./shipment/libiconv-2.dll
./shipment/libintl-8.dll
./shipment/msgbox-app.exe
./shipment/msgbox-app.img
./shipment/readline5.dll
./witchs-hat.ico
Here’s a picture how this all looks like on a Windows Server 2003 Standard Edition without any kind of lisp installed. And the entries in Process Explorer.
Some sort of shipment : )
show up in Process Explorer
Obviously one can develop a much more sophisticated bootstrapper. This one represents only the possibility of releasing software written in Lisp. Assembling these output files together into an installer could be the next step : ))
And finally, you can get either the binaries or the source files by sending a mail to:
% echo gra.rtebsrpehbf.ferfh@gyhnet | rev | tr '[a-z]' '[n-za-m]'
