"))
15 | (list "boot.lisp"
16 | "gui.lisp"
17 | "layout.lisp"
18 | "graphics.lisp"
19 | "base64.lisp"
20 | "locale.lisp"
21 | "rpc-client.lisp"))))
22 | (setf jslisp-html
23 | (raw-replace jslisp-html
24 | ""
29 | (+ ""
30 | (join libs "")
31 | "")))
40 | (put-file "jslisp-standalone.html"
41 | jslisp-html)
42 | (length jslisp-html))
--------------------------------------------------------------------------------
/uiclock.lisp:
--------------------------------------------------------------------------------
1 | (defun make-clock (tx ty)
2 | (let ((clock (sprite *root*
3 | (begin-path)
4 | (circle 0 0 120)
5 | (fill "#FFFFFF")
6 | (stroke "#000000" 2))))
7 | (dotimes (i 60)
8 | (let ((t (/ (* 2 pi i) 60)))
9 | (add-graphics clock
10 | (begin-path)
11 | (circle (* 110 (cos t))
12 | (* 110 (sin t))
13 | (if (= 0 (% i 5)) 4 2))
14 | (fill "#808080"))))
15 | (set-translation clock tx ty)
16 | (labels ((arm (w r)
17 | (sprite clock
18 | (begin-path)
19 | (move-to 0 (- w))
20 | (line-to r -1)
21 | (line-to r 1)
22 | (line-to 0 w)
23 | (close-path)
24 | (stroke "#000000" 1)
25 | (fill "#C0C0C0"))))
26 | (let ((hours (arm 8 80))
27 | (minutes (arm 6 100))
28 | (seconds (arm 4 115)))
29 | (sprite clock
30 | (begin-path)
31 | (circle 0 0 15)
32 | (stroke "#000000" 1)
33 | (fill "#FFFFFF"))
34 | (labels ((update ()
35 | (let* ((d (js-code "(new Date)"))
36 | (h (d.getHours))
37 | (m (d.getMinutes))
38 | (s (d.getSeconds)))
39 | (set-rotation hours (- (/ (* 2 pi h) 12) (/ pi 2)))
40 | (set-rotation minutes (- (/ (* 2 pi m) 60) (/ pi 2)))
41 | (set-rotation seconds (- (/ (* 2 pi s) 60) (/ pi 2))))))
42 | (update)
43 | (set-interval #'update 1000))))
44 | (setf clock.hit (drag clock))
45 | clock))
46 |
--------------------------------------------------------------------------------
/examples/primegraph.lisp:
--------------------------------------------------------------------------------
1 | (import * from gui)
2 | (import * from layout)
3 |
4 | (defun prime? (x)
5 | (cond
6 | ((= x 2) true)
7 | ((= x 3) true)
8 | ((< x 2) false)
9 | ((= 0 (% x 2)) false)
10 | (true
11 | (do ((q 3 (+ q 2)))
12 | ((or (= 0 (% x q))
13 | (> (* q q) x))
14 | (> (* q q) x))))))
15 |
16 | (defun primegraph ()
17 | (let** ((w (window 0 0 0.75 0.75 title: "Prime graph"))
18 | (canvas (add-widget w (create-element "canvas")))
19 | (#'resize ()
20 | (setf canvas.width canvas.offsetWidth)
21 | (setf canvas.height canvas.offsetHeight)
22 | (repaint))
23 | (#'repaint ()
24 | (let** ((ctx (canvas.getContext "2d"))
25 | (w canvas.width)
26 | (h canvas.height)
27 | (cx (ash w -1))
28 | (cy (ash h -1))
29 | (i 1)
30 | (#'line (n dx dy)
31 | (repeat n
32 | (when (and (< -1 cy h)
33 | (< -1 cx w)
34 | (prime? i))
35 | (ctx.fillRect cx cy 1 1))
36 | (incf i)
37 | (incf cx dx)
38 | (incf cy dy))))
39 | (setf ctx.fillStyle "#000")
40 | (ctx.fillRect 0 0 w h)
41 | (setf ctx.fillStyle "#FFF")
42 | (dolist (s (range 1 (max w h) 2))
43 | (line s 1 0)
44 | (line s 0 1)
45 | (line (1+ s) -1 0)
46 | (line (1+ s) 0 -1)))))
47 | (set-layout w (V border: 8 spacing: 8
48 | (dom canvas)))
49 | (setf canvas.data-resize #'resize)
50 | (show-window w center: true)))
51 |
52 | (defun main ()
53 | (primegraph))
54 |
55 | (main)
--------------------------------------------------------------------------------
/examples/demos.lisp:
--------------------------------------------------------------------------------
1 | (import * from gui)
2 |
3 | (defvar *menu* null)
4 |
5 | (defun make-menu ()
6 | (setf *menu* (set-style (create-element "div")
7 | position "absolute"
8 | px/left 0
9 | px/right 0
10 | px/top 0
11 | px/height 35
12 | backgroundColor "#E0E0E0"))
13 | (append-child document.body *menu*))
14 |
15 | (defun add-menu-option (name cback)
16 | (let ((btn (button name cback)))
17 | (let ((prev *menu*.lastChild))
18 | (append-child *menu* btn)
19 | (set-style btn
20 | position "absolute"
21 | px/left (+ (if prev (+ prev.offsetLeft prev.offsetWidth) 0) 2)
22 | px/top 2
23 | px/bottom 2))))
24 |
25 | (defvar *main-calls* (list))
26 |
27 | (defmacro import-nomain (module)
28 | (setf (symbol-macro (intern "main" (symbol-name module)))
29 | (lambda (&rest args)
30 | `(progn
31 | (push (list *current-module*
32 | (lambda ()
33 | (funcall #',#"main" ,@args)))
34 | *main-calls*)
35 | 'deferred)))
36 | `(import ,module))
37 |
38 | (import-nomain examples/3dboard)
39 | (import-nomain examples/crayons)
40 | (import-nomain examples/mandelbrot)
41 | (import-nomain examples/life)
42 | (import-nomain examples/tsp)
43 | (import-nomain examples/primegraph)
44 | (import-nomain examples/piechart)
45 | (import-nomain examples/hexa)
46 | (import-nomain examples/guitest)
47 | (import-nomain examples/3d)
48 | (import-nomain examples/mypaint)
49 | (import-nomain examples/flood-fill)
50 | (import-nomain examples/asteroids)
51 | (import-nomain examples/browser)
52 |
53 | (defun main ()
54 | (make-menu)
55 | (dolist ((name f) *main-calls*)
56 | (add-menu-option (slice name 9) f)))
57 |
58 | (main)
59 |
--------------------------------------------------------------------------------
/examples/forms.lisp:
--------------------------------------------------------------------------------
1 | (defobject document (name description pages))
2 |
3 | (defobject page (width height entities))
4 |
5 | (defobject rect (x0 y0 x1 y1 color))
6 |
7 | (defobject image (x0 y0 x1 y1 url))
8 |
9 | (defobject text (x0 y0 x1 y1
10 | text color size
11 | family bold italic))
12 |
13 | (defvar *docs* null)
14 |
15 | (when node-js
16 | (defun load-documents ()
17 | (unless *docs*
18 | (setf *docs* #())
19 | (dolist (L (split (get-file "forms.dat") "\n"))
20 | (unless (= 0 (length L))
21 | (let ((x (from-buffer (uri-decode L))))
22 | (cond
23 | ((= (first x) "+")
24 | (setf (aref *docs* (second x)) (third x)))
25 | ((= (first x) "-")
26 | (remove-key *docs* (second x)))
27 | (true (error "Unknown command {(str-value x)}")))))))))
28 |
29 | (rpc:defun list-documents ()
30 | (load-documents)
31 | (map (lambda (name) (list name (aref *docs* name).description))
32 | (keys *docs*)))
33 |
34 | (rpc:defun get-document (name)
35 | (load-documents)
36 | (aref *docs* name))
37 |
38 | (rpc:defun save-document (doc)
39 | (load-documents)
40 | (setf (aref *docs* doc.name) doc)
41 | ((js-code "require('fs')").appendFile "forms.dat"
42 | (+ (uri-encode (to-buffer `("+" ,doc.name ,doc))) "\n")
43 | (lambda (err) (when err (display "ERROR: {err}")))))
44 |
45 | (rpc:defun delete-document (name)
46 | (load-documents)
47 | (remove-key *docs* name)
48 | ((js-code "require('fs')").appendFile "forms.dat"
49 | (+ (uri-encode (to-buffer `("-" ,name))) "\n")
50 | (lambda (err) (when err (display "ERROR: {err}")))))
51 |
52 | (export new-rect rect?
53 | new-image image?
54 | new-text text?
55 | new-document document?
56 | new-page page?
57 | list-documents
58 | get-document
59 | save-document
60 | delete-document)
--------------------------------------------------------------------------------
/ilisp.lisp:
--------------------------------------------------------------------------------
1 | (import * from gui)
2 |
3 | (defobject ilisp (id iframe reqs default-cback))
4 |
5 | (defvar *id* 0)
6 | (defvar *req* 0)
7 |
8 | (defvar *instances* #())
9 |
10 | (defvar *cback-installed* false)
11 |
12 | (defun new (default-cback)
13 | (unless *cback-installed*
14 | (setf *cback-installed* true)
15 | (set-handler (js-code "window") onmessage
16 | (let ((x (aref *instances* event.data.id)))
17 | (when x
18 | (let ((cback (or (aref x.reqs event.data.req) x.default-cback)))
19 | (remove-key x.reqs event.data.req)
20 | (funcall cback event.data.reply))))))
21 | (let ((ilisp (make-ilisp id: (incf *id*)
22 | iframe: (create-element "iframe")
23 | reqs: #()
24 | default-cback: default-cback)))
25 | (setf (aref *instances* ilisp.id) ilisp)
26 | (setf ilisp.iframe.src ~"ilisp.html?{ilisp.id}")
27 | (set-style ilisp.iframe
28 | position "absolute"
29 | px/right 0
30 | px/top 0
31 | px/width 1
32 | px/height 1
33 | opacity 0.1)
34 | (append-child document.body ilisp.iframe)
35 |
36 | (setf ilisp.close (lambda ()
37 | (remove-key *instances* ilisp.id)
38 | (remove-child document.body ilisp.iframe)))
39 |
40 | (setf ilisp.send (lambda (type message &optional cback)
41 | (let ((req (incf *req*)))
42 | (setf (aref ilisp.reqs req) cback)
43 | (ilisp.iframe.contentWindow.postMessage
44 | #((type type)
45 | (text message)
46 | (req req))
47 | "*"))))
48 |
49 | (setf ilisp.reset (lambda ()
50 | (setf ilisp.iframe.src ~"ilisp.html?{ilisp.id}")))
51 |
52 | (setf ilisp.focus (lambda ()
53 | (ilisp.iframe.focus)))
54 |
55 | ilisp))
56 |
--------------------------------------------------------------------------------
/examples/test-db.lisp:
--------------------------------------------------------------------------------
1 | (import * from gui)
2 |
3 | (defun remote (x)
4 | (read (http-get (+ "eval?" (uri-encode (str-value x false))))))
5 |
6 | (defun records-window (table)
7 | (let* ((w (window 0 0 200 300 title: ~"Records {table}"))
8 | (cols (remote `(keys ,table)))
9 | (data (map (lambda (f)
10 | (remote `(. ,table ,f)))
11 | cols))
12 | (t (create-element "table"))
13 | (trh (create-element "tr")))
14 | (set-style t
15 | %/width 100
16 | %/height 100)
17 | (append-child t trh)
18 | (dolist (c cols)
19 | (let ((th (create-element "th")))
20 | (append-child trh th)
21 | (set-style th
22 | backgroundColor "#EEEEEE"
23 | border "solid 1px #000000"
24 | px/margin 0
25 | px/padding 4)
26 | (setf th.textContent c)))
27 | (dolist (r (apply #'zip data))
28 | (let ((tr (create-element "tr")))
29 | (append-child t tr)
30 | (dolist (field r)
31 | (let ((td (create-element "td")))
32 | (append-child tr td)
33 | (set-style td
34 | px/padding 4
35 | px/margin 0
36 | border "solid 1px #000000")
37 | (setf td.textContent field)))))
38 | (append-child w.client t)
39 | (show-window w)))
40 |
41 | (defun tables-window ()
42 | (let ((w (window 0 0 200 300 title: "Tables"))
43 | (tablelist (create-element "div")))
44 | (dolist (x (remote `*tables*))
45 | (let ((row (create-element "div")))
46 | (setf row.textContent x)
47 | (set-style row
48 | cursor "default")
49 | (set-handler row onmouseover (set-style row backgroundColor "#FFFF00"))
50 | (set-handler row onmouseout (set-style row backgroundColor "#FFFFFF"))
51 | (set-handler row onclick (records-window x))
52 | (append-child tablelist row)))
53 | (append-child w.client tablelist)
54 | (show-window w)))
55 |
56 | (tables-window)
--------------------------------------------------------------------------------
/numeri-in-lettere.lisp:
--------------------------------------------------------------------------------
1 | (defun numero-in-lettere (x)
2 | (if (< x 0)
3 | (+ "meno " (numero-in-lettere (- x)))
4 | (labels ((numero (x)
5 | (cond
6 | ((>= x 2000000000)
7 | (+ (numero (floor (/ x 1000000000)))
8 | "miliardI"
9 | (numero (% x 1000000000))))
10 | ((>= x 1000000000)
11 | (+ "unmiliardO" (numero (- x 1000000000))))
12 | ((>= x 2000000)
13 | (+ (numero (floor (/ x 1000000)))
14 | "milionI"
15 | (numero (% x 1000000))))
16 | ((>= x 1000000)
17 | (+ "unmilionE" (numero (- x 1000000))))
18 | ((>= x 2000)
19 | (+ (numero (floor (/ x 1000)))
20 | "milA"
21 | (numero (% x 1000))))
22 | ((>= x 1000)
23 | (+ "millE" (numero (- x 1000))))
24 | ((>= x 200)
25 | (+ (numero (floor (/ x 100)))
26 | "centO"
27 | (numero (% x 100))))
28 | ((>= x 100)
29 | (+ "centO" (numero (- x 100))))
30 | ((>= x 20)
31 | (+ (aref '("venti" "trenta" "quaranta" "cinquanta" "sessanta"
32 | "settanta" "ottanta" "novanta")
33 | (- (floor (/ x 10)) 2))
34 | (numero (% x 10))))
35 | (true
36 | (aref '("" "uno" "due" "tre" "quattro" "cinque" "sei" "sette"
37 | "otto" "nove" "dieci" "undici" "dodici" "tredici" "quattordici"
38 | "quindici" "sedici" "diciassette" "diciotto" "diciannove")
39 | x)))))
40 | (if (= x 0)
41 | "zero"
42 | (let ((s (numero x)))
43 | (setf s (replace s "[aeiou]uno" "uno"))
44 | (setf s (replace s "[aeiou]otto" "otto"))
45 | (lowercase s))))))
46 |
47 | (export numero-in-lettere)
--------------------------------------------------------------------------------
/slides.txt:
--------------------------------------------------------------------------------
1 | *1 JsLisp
2 | = JsLisp
3 | A Lisp compiler targeting Javascript
4 |
5 | *2 A Lisp compiler targeting Javascript
6 | {JsLisp is}
7 |
8 | - A Lisp
9 | - Compiler
10 | - Targeting Javascript
11 |
12 | *3 A Lisp
13 | {A Lisp}
14 |
15 | Lisp is a family of dialects, the two most
16 | known being Common Lisp and Scheme.
17 |
18 | JsLisp is close to Common Lisp
19 | but it's not Common Lisp.
20 |
21 | *3.1 Common Lisp similarities
22 | {JsLisp and Common Lisp similarities}
23 |
24 | - A Lisp-2 (actually a Lisp-3)
25 | - Macros and reader macros
26 | - Macro hygiene is not forced
27 | - Looping constructs [do], [dotimes], [dolist] ...
28 | - [tagbody/go], [throw/catch], [unwind-protect]
29 | - Namespace partitioning (similar to CL packages)
30 |
31 | *3.2 Common Lisp differences
32 | {JsLisp and Common Lisp differences}
33 |
34 | - No [cons] cells, lists are Javascript arrays
35 | - No numeric tower (only [double-float]s)
36 | - No [T]/[NIL]
37 | - [true], [false], [null], [undefined], [NaN]
38 | - [Lisp-3]: a function and a macro can have
39 | the same name. [(funcall #'x ...)] {may be}
40 | logically different from [(x ...)]. Rarely is.
41 |
42 | *4 Compiler
43 | {Compiler}
44 |
45 | JsLisp is a compiler-only implementation, there
46 | is no Lisp interpreter
47 |
48 | - Semantic checks at compile time
49 | - JsLisp functions are Javascript functions
50 | - Thanks to JIT speed is quite good
51 | - There is a treeshaker/minifier that provides
52 | source code protection
53 |
54 | *4.1 Semantic checks
55 | {Semantic checks}
56 |
57 | JsLisp compiler provides some semantic check
58 | at compile time:
59 |
60 | - References to undefined variables
61 | - References to undefined functions
62 | - Bad parameter count in static function calls
63 | - Bad keyword paramters in static function calls
64 | - Unused local variables
65 |
66 | *4.2 JsLisp functions are Javascript functions
67 | {compiles to Javascript functions}
68 |
69 | [[
70 | (defun square (x) (* x x))
71 | ;; ==> square
72 |
73 | ((function square).toString)
74 | ;; ==> "function (d$$x){return
75 | (((((d$$x)*(d$$x)))));}"
76 | ]]
77 |
78 | *5 Targeting Javascript
79 | {Targeting Javascript}
80 |
81 | - Runs in recent desktop browsers
82 | - Runs in HTML5 smartphones/tablets
83 | - Runs in node.js
84 |
85 | Running in [node.js] and in the browser allows a
86 | single-language solution for web applications
87 |
--------------------------------------------------------------------------------
/examples/barehtml.lisp:
--------------------------------------------------------------------------------
1 | (import * from html)
2 |
3 | (defun main ()
4 | (base-css "examples/base.css")
5 | (main-view "examples/main.html")
6 | (let** ((board (make-array 9 "-"))
7 | (color 0)
8 | (user "")
9 | (#'update ()
10 | (let** ((win null)
11 | (#'check (a b c)
12 | (if (and (not win)
13 | (/= (aref board a) "-")
14 | (= (aref board a) (aref board b) (aref board c)))
15 | (setf win (list a b c))))
16 | (winners '((0 1 2) (3 4 5) (6 7 8)
17 | (0 3 6) (1 4 7) (2 5 8)
18 | (0 4 8) (2 4 6))))
19 | (dolist ((a b c) winners)
20 | (check a b c))
21 | (when win
22 | (setf color -1)
23 | (dolist (x win)
24 | (set-style (. ##~"c{x}" parentNode)
25 | background-color "#F00")))
26 | (dotimes (i 9)
27 | (setf (. ##~"c{i}" src) (logo i)))))
28 | (#'new-game ()
29 | (dotimes (i 9)
30 | (set-style (. ##~"c{i}" parentNode)
31 | background-color null))
32 | (setf board (make-array 9 "-"))
33 | (setf color 0)
34 | (update))
35 | (#'logo (x)
36 | ~"img/{(aref board x)}.png")
37 | (#'login-view ()
38 | (set-view ##view "examples/login.html")
39 | (setf ##user.value "")
40 | (setf ##password.value "")
41 | (focus ##user))
42 | (#'check-password ()
43 | (if (and (= ##user.value "agri")
44 | (= ##password.value "pw"))
45 | (progn
46 | (setf user ##user.value)
47 | (board-view))
48 | (progn
49 | (focus ##user)
50 | (show ##errmsg text: "Invalid user/password" delay: 2000))))
51 | (#'play (i)
52 | (when (and (/= color -1) (= "-" (aref board i)))
53 | (setf (aref board i) (aref "ox" color))
54 | (setf color (- 1 color))
55 | (update)))
56 | (#'board-view ()
57 | (set-view ##view "examples/board.html")
58 | (update)))
59 | (login-view)))
60 |
61 | (main)
62 |
--------------------------------------------------------------------------------
/webdb.lisp:
--------------------------------------------------------------------------------
1 |
2 | (import * from simpledb)
3 |
4 | (defvar fs (js-code "require('fs')"))
5 |
6 | (let ((*no-transactions* true))
7 | (load (get-file "webdb.log")))
8 |
9 | (display "Data loaded")
10 |
11 | (setf *logwrite*
12 | (lambda (x)
13 | (fs.appendFile "webdb.log" (+ x "\n")
14 | (lambda (err)
15 | (when err
16 | (display ~"ERROR: {err}"))))))
17 |
18 | (defun start-server (address port handler)
19 | (let* ((http (js-code "require('http')"))
20 | (server (http.createServer handler)))
21 | (server.listen port address)))
22 |
23 | (defun parse-float (x)
24 | (js-code "parseFloat(d$$x)"))
25 |
26 | (defun web-eval (x)
27 | (toplevel-eval (read x)))
28 |
29 | (defun process (url parms data response)
30 | (display ~"Processing url={url}, parms={parms}, data={data}")
31 | (when (and (= parms "") (not (null? data)))
32 | (setf parms data))
33 | (let ((content (try (get-file (+ "." url) null)
34 | (try (str-value (apply (symbol-function #"web-{(slice url 1)}")
35 | (map #'uri-decode (split parms "&"))))
36 | (str-value *exception*))))
37 | (ctype (cond
38 | ((find ".html" url)
39 | "text/html")
40 | ((find ".css" url)
41 | "text/css")
42 | ((find ".js" url)
43 | "text/javascript")
44 | ((find ".jpg" url)
45 | "image/jpeg")
46 | ((find ".png" url)
47 | "image/png")
48 | (true "text/plain"))))
49 | (response.writeHead 200 #((Content-Type ctype)))
50 | (response.end content)))
51 |
52 | (defun my-handler (request response)
53 | (let ((url request.url)
54 | (parms null))
55 | (when (find "?" url)
56 | (let ((i (index "?" url)))
57 | (setf parms (slice url (1+ i)))
58 | (setf url (slice url 0 i))))
59 | (if (= request.method "POST")
60 | (let ((data ""))
61 | (request.on "data"
62 | (lambda (chunk)
63 | (incf data chunk)))
64 | (request.on "end"
65 | (lambda ()
66 | (process url parms data response))))
67 | (process url parms null response))))
68 |
69 | (start-server "127.0.0.1" 1337
70 | #'my-handler)
71 |
--------------------------------------------------------------------------------
/test-editor.lisp:
--------------------------------------------------------------------------------
1 | (import * from gui)
2 | (import * from layout)
3 | (import * from editor)
4 | (import * from rpc-client)
5 | (import (hash) from crypto)
6 | (import editor-cmode)
7 | (import editor-lispmode)
8 |
9 | (defun test-editor (name content)
10 | (let** ((w (window 0 0 640 480 title: name))
11 | (editor (add-widget w (editor name content
12 | (case (slice name (1+ (last-index "." name)))
13 | ("c" editor-cmode:mode)
14 | ("lisp" editor-lispmode:mode)
15 | (otherwise nullmode))))))
16 | (set-layout w (V border: 8 spacing: 8
17 | (dom editor)))
18 | (show-window w center: true)))
19 |
20 | (rpc:defun remote (user-name session-id x authcode))
21 | (rpc:defun login (user-name))
22 |
23 | (defvar *user*)
24 | (defvar *secret*)
25 | (defvar *session-id*)
26 |
27 | (defun call-remote (x)
28 | (remote *user* *session-id* x
29 | (hash (+ *session-id* *secret* (json* x)))))
30 |
31 | (defun get-file (name)
32 | (call-remote `(get-file ,name)))
33 |
34 | (defun files (path)
35 | (call-remote `((node:require "fs").readdirSync ,path)))
36 |
37 | (defun file-selector ()
38 | (let** ((w (window 0 0 640 400 title: "File selector"))
39 | (files (map (lambda (f)
40 | (list f))
41 | (sort
42 | (filter (lambda (x)
43 | ((regexp "\\.(lisp|c)$").exec x))
44 | (files ".")))))
45 | (filelist (add-widget w (table files
46 | rows: 25
47 | row-click: (lambda (row row-cells)
48 | (declare (ignorable row-cells))
49 | (test-editor
50 | (first row)
51 | (get-file (first row))))))))
52 | (set-layout w (V (dom filelist)))
53 | (show-window w center: true)))
54 |
55 | (defun main ()
56 | (gui:login (lambda (user pass)
57 | (when user
58 | (setf *user* user)
59 | (setf *secret* (hash pass))
60 | (setf *session-id* (login *user*))
61 | (file-selector)))))
62 |
63 | (main)
--------------------------------------------------------------------------------
/examples/bigfib.lisp:
--------------------------------------------------------------------------------
1 | (defconstant +BASE+ 10000000)
2 |
3 | (defun L+ (a b)
4 | "Sum of two large integers [a] and [b]"
5 | (do ((result (list))
6 | (carry 0)
7 | (na (length a))
8 | (nb (length b))
9 | (i 0 (1+ i)))
10 | ((and (>= i na) (>= i nb) (= carry 0))
11 | result)
12 | (let ((x (+ (or (aref a i) 0)
13 | (or (aref b i) 0)
14 | carry)))
15 | (if (>= x +BASE+)
16 | (progn
17 | (setf carry 1)
18 | (setf (aref result i) (- x +BASE+)))
19 | (progn
20 | (setf carry 0)
21 | (setf (aref result i) x))))))
22 |
23 | (defun Lk* (a k)
24 | "Product of a large integer [a] for a small integer [k]"
25 | (let ((result (list))
26 | (carry 0))
27 | (dolist (v a)
28 | (let ((x (+ (* v k) carry)))
29 | (push (% x +BASE+) result)
30 | (setf carry (floor (/ x +BASE+)))))
31 | (when carry
32 | (push carry result))
33 | result))
34 |
35 | (defun L* (a b)
36 | "Product of two large integers [a] and [b]"
37 | (let ((result (list)))
38 | (dolist (k b)
39 | (setf result (L+ result (Lk* a k)))
40 | (setf a (append '(0) a)))
41 | result))
42 |
43 | (defun Lmat2* (m1 m2)
44 | "Product of two 2x2 matrices"
45 | ;; a b e f
46 | ;; c d g h
47 | (let ((a (first m1))
48 | (b (second m1))
49 | (c (third m1))
50 | (d (fourth m1))
51 | (e (first m2))
52 | (f (second m2))
53 | (g (third m2))
54 | (h (fourth m2)))
55 | (list (L+ (L* a e) (L* b g))
56 | (L+ (L* a f) (L* b h))
57 | (L+ (L* c e) (L* d g))
58 | (L+ (L* c f) (L* d h)))))
59 |
60 | (defun Lmat2exp (m exp)
61 | "Raises 2x2 matrix [m] to the [exp] power"
62 | (cond
63 | ((= exp 0) (list 1 0 0 1))
64 | ((= exp 1) m)
65 | ((% exp 2) (Lmat2* m (Lmat2exp m (1- exp))))
66 | (true (let ((h (Lmat2exp m (ash exp -1))))
67 | (Lmat2* h h)))))
68 |
69 | (defun Lstr (n)
70 | "Converts a large integer to a string"
71 | (let ((x (apply #'+ (map (lambda (x)
72 | (let ((s ~"00000000{x}"))
73 | (slice s (- (length s) 7))))
74 | (reverse n)))))
75 | (replace x "^0*(.)" "$1")))
76 |
77 | (defun Lfibo (n)
78 | "Computes the [n]-th fibonacci number (result as a string)"
79 | (Lstr (first (Lmat2exp '((1)(1)
80 | (1)(0))
81 | n))))
82 |
--------------------------------------------------------------------------------
/xy.lisp:
--------------------------------------------------------------------------------
1 | (deftuple xy (x y))
2 |
3 | (defun xy+ (&rest args)
4 | "Addition of xy vectors"
5 | (let ((xx 0)
6 | (yy 0))
7 | (dolist (p args)
8 | (incf xx p.x)
9 | (incf yy p.y))
10 | (xy xx yy)))
11 |
12 | (defun xy- (a &optional b)
13 | "Difference or negation of xy vectors"
14 | (if b
15 | (xy (- a.x b.x) (- a.y b.y))
16 | (xy (- a.x) (- a.y))))
17 |
18 | (defun xy* (a k)
19 | "Scaling of an xy vector [a] by a scalar [k]"
20 | (xy (* a.x k)
21 | (* a.y k)))
22 |
23 | (defun xy/ (a k)
24 | "Inverse scaling of an xy vector [a] by a scalar [k]"
25 | (xy (/ a.x k)
26 | (/ a.y k)))
27 |
28 | (defun xy-cross (a b)
29 | "Cross-product of two xy vectors [a] and [b] as a scalar"
30 | (- (* a.x b.y)
31 | (* a.y b.x)))
32 |
33 | (defun xy-dot (a b)
34 | "Dot-product of two xy vectors [a] and [b]"
35 | (+ (* a.x b.x)
36 | (* a.y b.y)))
37 |
38 | (defun xy-abs2 (p)
39 | "Squared length of an xy vector [p]"
40 | (xy-dot p p))
41 |
42 | (defun xy-abs (p)
43 | "Lenght of an xy vector [p]"
44 | (sqrt (xy-dot p p)))
45 |
46 | (defun xy-dist2 (a b)
47 | "Squared distance between two xy vectors [a] and [b]"
48 | (xy-abs2 (xy- a b)))
49 |
50 | (defun xy-dist (a b)
51 | "Distance between two xy vectors [a] and [b]"
52 | (xy-abs (xy- a b)))
53 |
54 | (defun xy-avg (&rest pts)
55 | "Average of vectors [pts]"
56 | (xy/ (apply #'xy+ pts) (length pts)))
57 |
58 | (defun xy-ortho (a)
59 | "Left orthogonal of an xy vector [a]"
60 | (xy (- a.y) a.x))
61 |
62 | (defun xy-norm (a)
63 | "Normalized xy vector [a]"
64 | (xy* a (/ (xy-abs a))))
65 |
66 | (defun xy-arg (p)
67 | "Angle between xy vector [p] and +X"
68 | (atan2 p.y p.x))
69 |
70 | (defun xy-from-polar (rho theta)
71 | "Build an xy vector from polar coordinates [rho] and [theta]"
72 | (xy (* rho (cos theta))
73 | (* rho (sin theta))))
74 |
75 | (defun xy-inside (p pts)
76 | (let ((wc 0)
77 | (n (length pts))
78 | ((x y) p))
79 | (do ((j (1- n) i)
80 | (i 0 (1+ i)))
81 | ((= i n))
82 | (let (((x0 y0) (aref pts i))
83 | ((x1 y1) (aref pts j)))
84 | (when (and (<= (min y0 y1) y)
85 | (> (max y0 y1) y)
86 | (< x (+ x0 (/ (* (- y y0) (- x1 x0)) (- y1 y0)))))
87 | (incf wc (if (< y0 y1) 1 -1)))))
88 | (/= wc 0)))
89 |
90 | (export xy xy+ xy- xy* xy/
91 | xy-cross xy-dot
92 | xy-abs2 xy-abs xy-dist2 xy-dist
93 | xy-arg xy-from-polar
94 | xy-avg xy-ortho xy-norm
95 | xy-inside)
--------------------------------------------------------------------------------
/default_keybindings.txt:
--------------------------------------------------------------------------------
1 | # IDE Bindings ############################
2 |
3 | F1 edit-bindings
4 | alt-Enter run
5 | alt-Esc edit-zoom
6 | alt-I eval-expr
7 | alt-R ilisp-reset
8 | alt-Z ilisp-clear
9 | ctrl-D deploy
10 | ctrl-Enter eval-current
11 | ctrl-G gui-builder
12 | ctrl-K expr-run
13 | ctrl-Left prev
14 | ctrl-O mode-options
15 | ctrl-Q close
16 | ctrl-Right next
17 | ctrl-T terminal
18 | ctrl-W save
19 |
20 |
21 | # EDITOR Bindings #########################
22 |
23 | Backspace backspace
24 | Del delete
25 | Down down
26 | End line-end
27 | Enter enter
28 | Esc esc
29 | F3 record-macro
30 | F4 play-macro
31 | Home line-begin
32 | Left left
33 | PgDn page-down
34 | PgUp page-up
35 | Right right
36 | Tab indent
37 | Up up
38 | alt-#191 autocomplete
39 | alt-C copy
40 | alt-V paste
41 | alt-X cut
42 | ctrl-0 goto-0
43 | ctrl-1 goto-1
44 | ctrl-2 goto-2
45 | ctrl-3 goto-3
46 | ctrl-4 goto-4
47 | ctrl-5 goto-5
48 | ctrl-6 goto-6
49 | ctrl-7 goto-7
50 | ctrl-8 goto-8
51 | ctrl-9 goto-9
52 | ctrl-C copy
53 | ctrl-End text-end
54 | ctrl-Home text-begin
55 | ctrl-L goto-line
56 | ctrl-R find-replace
57 | ctrl-S isearch
58 | ctrl-V paste
59 | ctrl-X cut
60 | ctrl-Y redo
61 | ctrl-Z undo
62 | ctrl-alt-0 def-0
63 | ctrl-alt-1 def-1
64 | ctrl-alt-2 def-2
65 | ctrl-alt-3 def-3
66 | ctrl-alt-4 def-4
67 | ctrl-alt-5 def-5
68 | ctrl-alt-6 def-6
69 | ctrl-alt-7 def-7
70 | ctrl-alt-8 def-8
71 | ctrl-alt-9 def-9
72 | ctrl-shift-End text-end
73 | ctrl-shift-Home text-begin
74 | shift-Down down
75 | shift-End line-end
76 | shift-Home line-begin
77 | shift-Left left
78 | shift-PgDn page-down
79 | shift-PgUp page-up
80 | shift-Right right
81 | shift-Up up
--------------------------------------------------------------------------------
/examples/trifill.lisp:
--------------------------------------------------------------------------------
1 | (import * from gui)
2 | (import * from layout)
3 |
4 | (defun trifill ()
5 | (let** ((w (window 0 0 0.75 0.75 title: "Triangle-filling path"))
6 | (canvas (add-widget w (create-element "canvas")))
7 | (steps (add-widget w (select "steps" (range 2 100))))
8 | (#'recalc ()
9 | (let** ((w canvas.offsetWidth)
10 | (h canvas.offsetHeight)
11 | (ctx (canvas.getContext "2d"))
12 | (tx 10)
13 | (ty 10)
14 | (ta 0)
15 | (ts (/ (- (min w (/ h (sqrt 3) 0.5)) 20) (1- (atoi (text steps)))))
16 | (d (/ pi 3))
17 | (#'W ()
18 | (incf tx (* ts (cos ta)))
19 | (incf ty (* ts (sin ta)))
20 | (ctx.lineTo tx ty))
21 | (#'L (s)
22 | (incf ta (* s d)))
23 | (#'R (s)
24 | (decf ta (* s d)))
25 | (#'tri (n s)
26 | (cond
27 | ((= n 1))
28 | ((= n 2)
29 | (L s) (W) (R s) (R s) (W) (L s))
30 | ((odd? n)
31 | (let ((h (ash n -1)))
32 | (L s) (tri h (- s)) (W) (R s) (tri (- n h) s)
33 | (R s) (R s) (W) (tri h (- s)) (L s) (L s) (W) (tri h s)))
34 | ((> n 0)
35 | (let ((h (ash n -1)))
36 | (L s) (tri h (- s)) (W) (R s) (tri h s) (R s) (R s)
37 | (W) (tri (1- h) (- s)) (L s) (W) (L s) (tri h s))))))
38 | (setf canvas.width w)
39 | (setf canvas.height h)
40 | (setf ctx.fillStyle "#000")
41 | (ctx.fillRect 0 0 w h)
42 | (setf ctx.strokeStyle "#0F0")
43 | (setf ctx.lineWidth 4)
44 | (setf ctx.lineCap "round")
45 | (setf ctx.lineJoin "round")
46 | (ctx.beginPath)
47 | (ctx.moveTo tx ty)
48 | (tri (atoi (text steps)) 1)
49 | (ctx.stroke))))
50 | (setf canvas.data-resize #'recalc)
51 | (set-handler steps onchange (recalc))
52 | (set-layout w (V spacing: 8 border: 8
53 | (dom canvas)
54 | size: 40
55 | (H size: 80
56 | (dom steps)
57 | :filler:)))
58 | (focus steps)
59 | (show-window w center: true)))
60 |
61 | (defun main ()
62 | (trifill))
63 |
64 | (main)
--------------------------------------------------------------------------------
/site/about.txt:
--------------------------------------------------------------------------------
1 | @ About
2 |
3 | JsLisp is a Lisp(1) Compiler(2) targeting Javascript(3)
4 |
5 | In more detail...
6 |
7 | # (1) A Lisp
8 |
9 | JsLisp is a Lisp-2, similar to Common Lisp but is not Common Lisp
10 |
11 | - Symbols are case sensitive.
12 | - No cons cells. Lists are represented using Javascript lists.
13 | - Lists are first-class objects. [push] is a regular function.
14 | - No numeric tower. Numbers are double-precision floats (they provide
15 | 53 bits of integer numeric accuracy).
16 | - Dynamic and lexical variables.
17 | - There can be both a function and a macro with the same name. Macro
18 | is used in explicit calls, function can be used for [funcall]/[apply].
19 | - [NaN], [null], [undefined], [false], [0] are present with their
20 | Javascript value semantic.
21 | - No [NIL]/[T]. Truth values are Javscript [true]/[false].
22 | - [defmacro], [define-symbol-macro], [macrolet], [symbol-macrolet] are
23 | present mimicking Common Lisp semantic. Quasiquoting.
24 | - Read macros.
25 | - Interpolated string literals.
26 | - No [loop] macro for now.
27 |
28 | # (2) Compiler
29 |
30 | JsLisp is a compile-only implementation and contains no interpreter,
31 | [eval] is implemented by compiling and executing. The core of the
32 | compiler is hand-written Javascript, everything else is written in
33 | JsLisp itself (boot.lisp).
34 |
35 | Compiled functions are regular Javscript functions, callable from
36 | Javascript code (with the exception of keyword arguments) and they
37 | can call Javascript code.
38 |
39 | Javascript inlining is possible and used heavily in the default
40 | runtime library. Name mangling is necessary when converting JsLisp
41 | symbol names to Javascript and vice versa [(mangle x)]/[(demangle x)].
42 |
43 | Compiler does a few static checks at compile time:
44 |
45 | - Unknown variables
46 | - Unknown functions
47 | - Wrong number of arguments or wrong keyword arguments in a static call
48 | - Unused locals
49 | - Map over a lambda with the wrong number of arguments
50 |
51 | JsLisp also supports docstrings and doctests (i.e. tests embedded in
52 | the docstring, ensuring conformance).
53 |
54 | # (3) Targeting Javascript
55 |
56 | No attempt is made to create human-readable idiomatic Javascript,
57 | generated code is not meant to be manually maintained.
58 |
59 | Works with recent browsers and node.js.
60 |
61 | Using node.js allows writing the server side and the client side
62 | of a web application in a single language. There is also an
63 | RPC module that facilitates the approach by avoiding any
64 | explicit binding (you can just define the functions in a module
65 | using [rpc-defun] and they will be callable by the client and
66 | will run in the server).
67 |
68 | Any Javascript functions or methods can be called from JsLisp.
69 | JsLisp code can be called by Javascript or used as event handler.
70 |
71 |
--------------------------------------------------------------------------------
/test-treeview.lisp:
--------------------------------------------------------------------------------
1 | (import * from gui)
2 | (import * from layout)
3 |
4 | (defobject node (text children))
5 |
6 | (defun node (text &rest args)
7 | (new-node text args))
8 |
9 | (defun test-treeview ()
10 | (let** ((w (window 0 0 0.75 0.75 title: "TreeView"))
11 | (tree (node "Root"
12 | (node "1"
13 | (node "1.1")
14 | (node "1.2"))
15 | (node "2"
16 | (node "2.1"))
17 | (node "3"
18 | (node "3.1")
19 | (node "3.2")
20 | (node "3.3")
21 | (node "3.4"))))
22 | (tw (add-widget w (tree-view tree onclick: #'edit)))
23 | (add (add-widget w (button "Add" #'add)))
24 | (cut (add-widget w (button "Cut" #'cut)))
25 | (paste (add-widget w (button "Paste" #'paste)))
26 | (clipboard null)
27 | (#'edit (n)
28 | (let ((name (prompt "New node name?")))
29 | (when name
30 | (setf n.text name)
31 | (tw.rebuild))))
32 | (#'add ()
33 | (let ((name (prompt "Node name?")))
34 | (when name
35 | (baloon "Select insert point")
36 | (tw.select-place (lambda (parent index)
37 | (insert parent.children index (node name))
38 | (tw.rebuild))))))
39 | (#'cut ()
40 | (baloon "Select node")
41 | (tw.select-node (lambda (n)
42 | (setf clipboard n)
43 | (let** ((#'remove-from (x)
44 | (nremove n x.children)
45 | (dolist (c x.children)
46 | (remove-from c))))
47 | (remove-from tree)
48 | (tw.rebuild)))))
49 | (#'paste ()
50 | (when clipboard
51 | (baloon "Select insert point")
52 | (tw.select-place (lambda (parent index)
53 | (insert parent.children index clipboard)
54 | (setf clipboard null)
55 | (tw.rebuild))))))
56 | (set-layout w (V border: 8 spacing: 8
57 | (dom tw)
58 | size: 30
59 | (H :filler:
60 | size: 80
61 | (dom add)
62 | (dom cut)
63 | (dom paste)
64 | :filler:)))
65 | (show-window w center: true)))
66 |
67 | (defun main ()
68 | (test-treeview))
69 |
70 | (main)
71 |
--------------------------------------------------------------------------------
/delta-coding.lisp:
--------------------------------------------------------------------------------
1 | (defun longest-match (haystack needle)
2 | "Returns the size and position of the longest partial match of [needle] \
3 | in [haystack]. Returns [(0 0)] if the first character of [needle] is not \
4 | present in [haystack]"
5 | (do ((best 0)
6 | (best-index 0)
7 | (i 0))
8 | ((or (>= best (length needle))
9 | (>= i (- (length haystack) best)))
10 | (list best best-index))
11 |
12 | (if (= (slice haystack i (+ i best 1))
13 | (slice needle 0 (+ best 1)))
14 | (progn
15 | (setf best-index i)
16 | (incf best))
17 | (incf i))))
18 |
19 | (defconstant +ALPHABET+ "ABCDEFGHIJKLMNOPQRSTUVWXYZ\
20 | abcdefghijklmnopqrstuvwxyz\
21 | 0123456789+/")
22 |
23 | (defun encode-uint (x)
24 | (if (> x 31)
25 | (+ (aref +ALPHABET+ (+ 32 (logand x 31))) (encode-uint (ash x -5)))
26 | (aref +ALPHABET+ x)))
27 |
28 | (defun encode-int (x)
29 | (if (< x 0)
30 | (encode-uint (1+ (* x -2)))
31 | (encode-uint (* x 2))))
32 |
33 | (defmacro decode-uint (delta i)
34 | (let ((x '#.(gensym))
35 | (shift '#.(gensym))
36 | (c '#.(gensym)))
37 | `(do ((,x 0)
38 | (,shift 0)
39 | (,c (index (aref ,delta (1- (incf ,i))) +ALPHABET+)))
40 | ((< ,c 32) (+ ,x (ash ,c ,shift)))
41 | (incf ,x (ash (- ,c 32) ,shift))
42 | (incf ,shift 5)
43 | (setf ,c (index (aref ,delta (1- (incf ,i))) +ALPHABET+)))))
44 |
45 | (defun decode-int (x)
46 | (if (logand x 1)
47 | (- (ash x -1))
48 | (ash x -1)))
49 |
50 | (defun delta-encode (current new)
51 | "Returns a compressed delta needed to compute [new] from [current]"
52 | (let ((res "")
53 | (i0 0)
54 | (i 0))
55 | (labels ((flush ()
56 | (when (> i i0)
57 | (incf res (+ (encode-int (- i0 i)) (slice new i0 i)))
58 | (setf i0 i))))
59 | (do () ((>= i (length new)) (flush) res)
60 | (let (((sz pos) (longest-match (+ current (slice new 0 i)) (slice new i))))
61 | (if (<= sz 4)
62 | (incf i)
63 | (progn
64 | (flush)
65 | (incf res (+ (encode-int sz) (encode-uint pos)))
66 | (incf i sz)
67 | (setf i0 i))))))))
68 |
69 | (defun delta-decode (current delta)
70 | "Returns a new version given [current] and a delta-encoded list of changes [delta]"
71 | (do ((res current)
72 | (i 0))
73 | ((>= i (length delta)) (slice res (length current)))
74 | (let ((x1 (decode-int (decode-uint delta i))))
75 | (if (< x1 0)
76 | (progn
77 | (incf res (slice delta i (- i x1)))
78 | (decf i x1))
79 | (let ((x2 (decode-uint delta i)))
80 | (incf res (slice res x2 (+ x1 x2))))))))
81 |
82 | (export delta-encode delta-decode)
83 |
--------------------------------------------------------------------------------
/site/license.txt:
--------------------------------------------------------------------------------
1 | @ License
2 |
3 | I am not a lawyer and I just hope this is enough to leave me out
4 | of jail... if you think it's not, then please drop me a line.
5 |
6 | The intention is that you can use JsLisp for whatever you want
7 | (commercial or not) provided you just don't pretend you did something
8 | that I did or that you blame me if you have any problem.
9 |
10 | <<
11 |
13 |
Copyright (c) 2011-2013 by Andrea Griffini
14 |
15 |
Permission is hereby granted, free of charge, to any person obtaining
16 | a copy of this software and associated documentation files (the
17 | "Software"), to deal in the Software without restriction, including
18 | without limitation the rights to use, copy, modify, merge, publish,
19 | distribute, sublicense, and/or sell copies of the Software, and to
20 | permit persons to whom the Software is furnished to do so, subject to
21 | the following conditions:
22 |
23 |
24 |
25 | The above copyright notice and this permission notice shall be
26 | included in all copies or substantial portions of the Software.
27 |
28 |
29 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
30 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
31 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
32 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
33 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
34 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
35 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
36 |
37 |
38 | >>
39 |
40 | <<
41 |
44 |
WARNING
45 |
PLEASE NOTE THAT CURRENTLY I'M APPARENTLY THE ONLY USER OF THE
46 | LANGUAGE AND I JUST CHANGE THINGS AT MY WILL WITHOUT CARING ABOUT
47 | BACKWARD COMPATIBILITY.
48 |
IF YOU DECIDE TO USE IT FOR ANYTHING PLEASE BE SURE TO UNDERSTAND
49 | THAT I'M NOT NECESSARILY GOING TO HELP YOU ON THIS INSTABILITY
50 | ISSUE.
51 |
52 | >>
53 |
54 | Note that of course I'm open about hearing any suggestion or
55 | critics... but I'm not currently willing to take to extra load of
56 | thinking to someone else using JsLisp. I am using it for some pet
57 | projects but if you do then please be sure you're also ready to pay
58 | the price (i.e. porting everything or eventually maintaining your
59 | clone of JsLisp).
60 |
61 | In all honesty I don't refrain from making changes just because of my
62 | already existing codebase. At the moment however I won't stop because
63 | of your codebase either.
64 |
65 |
--------------------------------------------------------------------------------
/debugserver.lisp:
--------------------------------------------------------------------------------
1 | (defun start-server (address port handler)
2 | (let* ((http (js-code "require('http')"))
3 | (server (funcall (. http createServer) handler)))
4 | (funcall (. server listen) port address)))
5 |
6 | (defun reply (response content-type msg)
7 | (funcall (. response writeHead) 200 #((Content-type content-type)))
8 | (funcall (. response end) msg))
9 |
10 | (defvar *current-location* null)
11 | (defvar *pending-response* null)
12 | (defvar *pending-reply* null)
13 |
14 | (defun idler ()
15 | (when *pending-response*
16 | (reply *pending-response* "text/plain" "0")
17 | (setf *pending-response* null)))
18 |
19 | (set-interval #'idler 10000)
20 |
21 | (defun send (msg)
22 | (if *pending-response*
23 | (progn
24 | (reply *pending-response* "text/plain" msg)
25 | (setf *pending-response* null))
26 | (setf *pending-reply* msg)))
27 |
28 | (defun handler (request response)
29 | (let ((url (. request url))
30 | (parms ""))
31 | (when (find "?" url)
32 | (let ((i (index "?" url)))
33 | (setf parms (slice url (1+ i)))
34 | (setf url (slice url 0 i))))
35 | (let ((f (symbol-function (intern (slice url 1)))))
36 | (if f
37 | (apply f (append (list response)
38 | (map #'uri-decode (split parms "&"))))
39 | (let ((content (try (get-file (+ "." url) null)
40 | (str-value *exception*)))
41 | (ctype (cond
42 | ((find ".html" url)
43 | "text/html")
44 | ((find ".css" url)
45 | "text/css")
46 | ((find ".js" url)
47 | "text/javascript")
48 | ((find ".jpg" url)
49 | "image/jpeg")
50 | ((find ".png" url)
51 | "image/png")
52 | (true "text/plain"))))
53 | (reply response ctype content))))))
54 |
55 | (defun cmd (response location)
56 | (setf *current-location* location)
57 | (setf *pending-response* response)
58 | (when *pending-reply*
59 | (send *pending-reply*)
60 | (setf *pending-reply* null)))
61 |
62 | (defvar *data-wait* null)
63 |
64 | (defun data (response msg)
65 | (when *data-wait*
66 | (reply *data-wait* "text/plain" msg)
67 | (setf *data-wait* null))
68 | (reply response "text/plain" "ok"))
69 |
70 | (defun info (response)
71 | (reply response "text/plain" (+ "" *current-location*)))
72 |
73 | (defun getdata (response expr)
74 | (send ~"f$$http_get(\"http://127.0.0.1:1337/data?\"+encodeURIComponent(safe(ee,\"{expr}\")));")
75 | (setf *data-wait* response))
76 |
77 | (defun step (response)
78 | (send "cont")
79 | (setf *current-location* null)
80 | (reply response "text/plain" "ok"))
81 |
82 | (start-server "127.0.0.1" 1337
83 | #'handler)
84 |
--------------------------------------------------------------------------------
/examples/clipping.lisp:
--------------------------------------------------------------------------------
1 | (import * from gui)
2 | (import * from layout)
3 |
4 | (defun spans (boundary y)
5 | (do ((ixs (list))
6 | (j (1- (length boundary)) i)
7 | (i 0 (1+ i)))
8 | ((= i (length boundary)) (sort ixs))
9 | (let (((x0 y0) (aref boundary j))
10 | ((x1 y1) (aref boundary i)))
11 | (when (or (and (<= y0 y) (< y y1))
12 | (and (<= y1 y) (< y y0)))
13 | (push (+ x0 (/ (* (- y y0) (- x1 x0)) (- y1 y0)))
14 | ixs)))))
15 |
16 | (defun hatch (ctx boundary angle step)
17 | (let** ((cos (cos angle))
18 | (sin (sin angle))
19 | (mpts (map (lambda (p)
20 | (let (((x y) p))
21 | (list (+ (* cos x) (* sin y))
22 | (- (* cos y) (* sin x)))))
23 | boundary))
24 | (y0 (apply #'min (map #'second mpts)))
25 | (y1 (apply #'max (map #'second mpts))))
26 | (do ((y (* (floor (/ y0 step)) step) (+ y step)))
27 | ((> y y1))
28 | (let** ((spans (spans mpts y))
29 | (xspans (map (lambda (x)
30 | (list (- (* cos x) (* sin y))
31 | (+ (* cos y) (* sin x))))
32 | spans)))
33 | (dolist (i (range 0 (1- (length xspans)) 2))
34 | (ctx.moveTo (aref xspans i 0) (aref xspans i 1))
35 | (ctx.lineTo (aref xspans (1+ i) 0) (aref xspans (1+ i) 1)))))))
36 |
37 | (defun clipping ()
38 | (let** ((w (window 0 0 0.75 0.75 title: "Clipping"))
39 | (canvas (add-widget w (create-element "canvas")))
40 | (ctx (canvas.getContext "2d"))
41 | (pts (list))
42 | (#'repaint ()
43 | (setf canvas.width canvas.offsetWidth)
44 | (setf canvas.height canvas.offsetHeight)
45 | (setf ctx.fillStyle "#000")
46 | (ctx.fillRect 0 0 canvas.width canvas.height)
47 | (setf ctx.lineWidth 2)
48 | (setf ctx.strokeStyle "#080")
49 | (ctx.beginPath)
50 | (let ((angle (/ (clock) 20000)))
51 | (hatch ctx pts angle 20)
52 | (hatch ctx pts (+ angle (/ pi 3)) 20)
53 | (hatch ctx pts (+ angle (* 2 (/ pi 3))) 20))
54 | (ctx.stroke)
55 | (ctx.beginPath)
56 | (enumerate (i (x y) pts)
57 | (if i
58 | (ctx.lineTo x y)
59 | (ctx.moveTo x y)))
60 | (ctx.closePath)
61 | (setf ctx.strokeStyle "#FFF")
62 | (ctx.stroke))
63 | (#'down (x y)
64 | (push (list x y) pts)
65 | (repaint)))
66 | (set-layout w (V border: 8 spacing: 8
67 | (dom canvas)))
68 | (setf canvas.data-resize #'repaint)
69 | (set-handler canvas onmousedown
70 | (event.preventDefault)
71 | (event.stopPropagation)
72 | (apply #'down (relative-pos event canvas)))
73 | (set-interval #'repaint 20)
74 | (show-window w center: true)))
75 |
76 | (defun main ()
77 | (clipping))
78 |
79 | (main)
--------------------------------------------------------------------------------
/test-fibo.lisp:
--------------------------------------------------------------------------------
1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 | ;;; ;;;
4 | ;;; Copyright (c) 2011 by Andrea Griffini ;;;
5 | ;;; ;;;
6 | ;;; Permission is hereby granted, free of charge, to any person obtaining ;;;
7 | ;;; a copy of this software and associated documentation files (the ;;;
8 | ;;; "Software"), to deal in the Software without restriction, including ;;;
9 | ;;; without limitation the rights to use, copy, modify, merge, publish, ;;;
10 | ;;; distribute, sublicense, and/or sell copies of the Software, and to ;;;
11 | ;;; permit persons to whom the Software is furnished to do so, subject to ;;;
12 | ;;; the following conditions: ;;;
13 | ;;; ;;;
14 | ;;; The above copyright notice and this permission notice shall be ;;;
15 | ;;; included in all copies or substantial portions of the Software. ;;;
16 | ;;; ;;;
17 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;;
18 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;;
19 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;;
20 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE ;;;
21 | ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION ;;;
22 | ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION ;;;
23 | ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;;;
24 | ;;; ;;;
25 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27 |
28 | (defun fibo (x)
29 | (if (< x 2)
30 | 1
31 | (+ (fibo (- x 1))
32 | (fibo (- x 2)))))
33 | (defun test-fibo (n)
34 | (dotimes (i n)
35 | (display (+ "(fibo " i ") --> " (fibo i)))))
36 |
37 | (time (test-fibo 30))
38 |
39 | (defun fibo (n)
40 | ; f(n) = f(n-1) + f(n-2) = a + b
41 | ; f(n+1) = f(n) + f(n-1) = a' + b'
42 | ; a' = a+b
43 | ; b' = a
44 | (labels ((ff (a b count)
45 | (if (= count n)
46 | (+ a b)
47 | (ff (+ a b) a (1+ count)))))
48 | (if (< n 2)
49 | 1
50 | (ff 1 1 2))))
51 |
52 | (defun memoized (f)
53 | (let ((cache #()))
54 | (lambda (&rest x)
55 | (let ((cached-result (aref cache x)))
56 | (if (= cached-result undefined)
57 | (setf (aref cache x)
58 | (apply f x))
59 | cached-result)))))
60 |
61 | (setf #'fibo (memoized #'fibo))
62 |
63 | (time (test-fibo 30))
64 |
--------------------------------------------------------------------------------
/keybindings_help.html:
--------------------------------------------------------------------------------
1 |
How to specify key bindings
2 |
3 | Each key binding requires a line with the key combination and a command separated by spaces.
4 |
5 |
Key combination syntax
6 |
7 | The key combination can be preceded by zero or more prefixes:
8 |
9 |
10 |
ctrl-
11 |
shift-
12 |
alt-
13 |
14 |
15 | Note that in case of multiple prefixes the order must be respected.
16 |
17 |
18 | After prefix part (that may be empty) there is the key name.
19 | A few special keys have a specific name:
20 | Left,
21 | Right,
22 | Up,
23 | Down
24 | PgUp,
25 | PgDn,
26 | Home,
27 | End,
28 | Space,
29 | Backspace,
30 | Del,
31 | Tab,
32 | Esc,
33 | Enter,
34 | F1,
35 | F2,
36 | F3, ...,
37 | F12.
38 |
39 |
40 | In addition to those special keys any uppercase character or digit can
41 | be used to represent the correspondig key.
42 |
43 |
44 | To create a mapping that involves a key that is not listed otherwise
45 | it is also possible to use for example #197
46 | to specify the key for which event.which
47 | has value 197 in the processing of onkeydown
48 | Javascript event.
49 |
50 |
51 | For example are valid key combinations:
52 |
53 |
54 |
ctrl-Left
55 |
alt-W
56 |
ctrl-alt-2
57 |
F11
58 |
alt-#197
59 |
60 |
61 | While instead are invalid:
62 |
63 |
64 |
shift-ctrl-Left (modifiers order must be preserved)
65 |
ctrl-$ (only A-Z and 0-9 can be used)
66 |
67 |
Command syntax
68 |
69 | The command associated to a key combination is a single word (optionally containing hypens).
70 | Which commands are acceptable depends on the section (IDE or EDITOR).
71 |
72 |
IDE commands
73 |
74 | {{IDE-COMMANDS}}
75 |
76 |
EDITOR commands
77 |
78 | {{EDITOR-COMMANDS}}
79 |
80 |
--------------------------------------------------------------------------------
/geo3d.lisp:
--------------------------------------------------------------------------------
1 | (defun v (&rest coords) coords)
2 |
3 | (defun x (p) (first p))
4 | (defun y (p) (second p))
5 | (defun z (p) (third p))
6 |
7 | (defun v+ (&rest pts)
8 | (reduce (lambda (a b) (map #'+ a b)) pts))
9 |
10 | (defun v- (&rest pts)
11 | (reduce (lambda (a b) (map #'- a b)) pts))
12 |
13 | (defun v* (v k)
14 | (map (lambda (x) (* x k)) v))
15 |
16 | (defun v/ (v k)
17 | (map (lambda (x) (/ x k)) v))
18 |
19 | (defun vdot (a b)
20 | (reduce #'+ (map #'* a b)))
21 |
22 | (defun vlen (x)
23 | (sqrt (vdot x x)))
24 |
25 | (defun vdir (x)
26 | (v/ x (vlen x)))
27 |
28 | (defun v^ (a b)
29 | (v (- (* (y a) (z b)) (* (z a) (y b)))
30 | (- (* (z a) (x b)) (* (x a) (z b)))
31 | (- (* (x a) (y b)) (* (y a) (x b)))))
32 |
33 | (defobject camera (o u v n))
34 |
35 | (defun camera (from to up dist)
36 | (let* ((n (vdir (v- to from)))
37 | (u (v* (vdir (v^ up n)) dist))
38 | (v (v^ n u)))
39 | (make-camera o: from
40 | n: n
41 | u: u
42 | v: v)))
43 |
44 | (defun camera-map (camera p)
45 | (let* ((x (v- p camera.o))
46 | (z (vdot x camera.n))
47 | (zs (/ z))
48 | (xs (* (vdot x camera.u) zs))
49 | (ys (* (vdot x camera.v) zs)))
50 | (v xs ys zs)))
51 |
52 | (defun camera-invmap (camera xs ys)
53 | (let ((dist (vlen camera.u)))
54 | (v+ camera.o
55 | (v* camera.u (/ xs dist))
56 | (v* camera.v (/ ys dist))
57 | (v* camera.n dist))))
58 |
59 | (defun camera-normalize (camera &optional (dist (vlen camera.u)))
60 | (let ((n camera.n)
61 | (u camera.u))
62 | (setf camera.n (vdir n))
63 | (setf u (v- u (v* n (vdot u n))))
64 | (setf camera.u (v* (vdir u) dist))
65 | (setf camera.v
66 | (v^ camera.n
67 | camera.u))))
68 |
69 | (defun xrot (angle)
70 | (let ((c (cos angle))
71 | (s (sin angle))
72 | (n (- (sin angle))))
73 | (list 1 0 0
74 | 0 c s
75 | 0 n c
76 | 0 0 0)))
77 |
78 | (defun yrot (angle)
79 | (let ((c (cos angle))
80 | (s (sin angle))
81 | (n (- (sin angle))))
82 | (list c 0 s
83 | 0 1 0
84 | n 0 c
85 | 0 0 0)))
86 |
87 | (defun zrot (angle)
88 | (let ((c (cos angle))
89 | (s (sin angle))
90 | (n (- (sin angle))))
91 | (list c s 0
92 | n c 0
93 | 0 0 1
94 | 0 0 0)))
95 |
96 | (defun xform (m p)
97 | (let ((x (x p))
98 | (y (y p))
99 | (z (z p)))
100 | (v (+ (* x (aref m 0))
101 | (* y (aref m 3))
102 | (* z (aref m 6))
103 | (aref m 9))
104 | (+ (* x (aref m 1))
105 | (* y (aref m 4))
106 | (* z (aref m 7))
107 | (aref m 10))
108 | (+ (* x (aref m 2))
109 | (* y (aref m 5))
110 | (* z (aref m 8))
111 | (aref m 11)))))
112 |
113 | (export v x y z
114 | v+ v- v* v/ vdot vlen vdir v^
115 | camera "camera-" "set-camera-"
116 | camera-map camera-invmap camera-normalize
117 | xrot yrot zrot
118 | xform)
--------------------------------------------------------------------------------
/examples/simple-graph.lisp:
--------------------------------------------------------------------------------
1 | (import * from gui)
2 | (import * from layout)
3 |
4 | (defun simple-graph ()
5 | (let** ((w (window 0 0 0.75 0.75 title: "Simple graph"))
6 | (data (add-widget w (text-area "data")))
7 | (ok (add-widget w (button "OK" #'ok)))
8 | (#'ok ()
9 | (let** ((w (window 0 0 0.75 0.75 title: "Graph"))
10 | (values (filter (lambda (x) (not (NaN? x)))
11 | (map #'atof (split (text data) "\n"))))
12 | (canvas (add-widget w (create-element "canvas")))
13 | (ctx (canvas.getContext "2d"))
14 | (#'repaint ()
15 | (let** ((min (apply #'min values))
16 | (max (apply #'max values))
17 | (delta (- max min))
18 | (w canvas.offsetWidth)
19 | (h canvas.offsetHeight))
20 | (decf min (/ delta 10))
21 | (incf max (/ delta 10))
22 | (setf delta (- max min))
23 | (setf canvas.width w)
24 | (setf canvas.height h)
25 | (ctx.beginPath)
26 | (enumerate (x y values)
27 | (let ((xx (* (+ 0.5 x) w (/ (length values))))
28 | (yy (* (- max y) h (/ delta))))
29 | (if (= x 0)
30 | (ctx.moveTo xx yy)
31 | (ctx.lineTo xx yy))))
32 | (setf ctx.lineWidth 2)
33 | (setf ctx.strokeStyle "#F00")
34 | (ctx.stroke)
35 | (setf ctx.lineWidth 1)
36 | (setf ctx.strokeStyle "#CCC")
37 | (setf ctx.fillStyle "#000")
38 | (let ((step 1))
39 | (do () ((< (* 10 step) delta))
40 | (setf step (* step 0.5)))
41 | (do () ((> (* 10 step) delta))
42 | (setf step (* step 2)))
43 | (dolist (iy (range (1- (floor (/ min step)))
44 | (+ 2 (floor (/ max step)))))
45 | (let* ((y (* iy step))
46 | (yy (* (- max y) h (/ delta))))
47 | (ctx.beginPath)
48 | (ctx.moveTo 0 yy)
49 | (ctx.lineTo w yy)
50 | (ctx.stroke)
51 | (ctx.fillText (json y) 0 yy)))))))
52 | (set-layout w (V border: 8 spacing: 8
53 | (dom canvas)))
54 | (setf canvas.data-resize #'repaint)
55 | (show-window w center: true))))
56 | (set-layout w (V border: 8 spacing: 8
57 | (dom data)
58 | size: 30
59 | (H :filler: size: 80 (dom ok) :filler:)))
60 | (focus data)
61 | (show-window w center: true)))
62 |
63 | (defun main ()
64 | (simple-graph))
65 |
66 | (main)
67 |
--------------------------------------------------------------------------------
/pdf.lisp:
--------------------------------------------------------------------------------
1 | (defvar *pdf* null)
2 |
3 | (defun pt (x) x)
4 | (defun mm (x) (* x #.(/ 72 25.4)))
5 | (defun x () *pdf*.x)
6 | (defun y () *pdf*.y)
7 |
8 | (defvar PDFDocument null)
9 |
10 | (defun new-pdf (&optional (size "a4") (layout "portrait"))
11 | (unless PDFDocument
12 | (setf PDFDocument (js-code "require('pdfkit')")))
13 | (js-code "(new dpdf$$PDFDocument({size:d$$size, layout:dpdf$$layout}))"))
14 |
15 | (defmacro pdf (options &rest body)
16 | `(let ((*pdf* (new-pdf ,@options)))
17 | ,@body
18 | *pdf*))
19 |
20 | (defun new-page (&optional size layout)
21 | (if size
22 | (if layout
23 | (*pdf*.addPage #((size size)
24 | (layout layout)))
25 | (*pdf*.addPage #((size size))))
26 | (*pdf*.addPage)))
27 |
28 | (defun text (text &optional x y
29 | &key align
30 | width height
31 | columns column-gap
32 | indent
33 | paragraph-gap line-gap
34 | word-spacing character-spacing
35 | fill stroke)
36 | (*pdf*.text text x y
37 | #((align align)
38 | (width width)
39 | (height height)
40 | (columns columns)
41 | (columnGap column-gap)
42 | (indent indent)
43 | (paragraphGap paragraph-gap)
44 | (wordSpacing word-spacing)
45 | (characterSpacing character-spacing)
46 | (fill fill)
47 | (stroke stroke))))
48 |
49 | (defun font (name &optional style)
50 | (*pdf*.font name style))
51 |
52 | (defun font-size (size)
53 | (*pdf*.fontSize size))
54 |
55 | (defun down (step)
56 | (*pdf*.moveDown step))
57 |
58 | (defun line-width (size)
59 | (*pdf*.lineWidth size))
60 |
61 | (defun stroke-color (color)
62 | (*pdf*.strokeColor color))
63 |
64 | (defun fill-color (color)
65 | (*pdf*.fillColor color))
66 |
67 | (defun stroke-opacity (opacity)
68 | (*pdf*.strokeOpacity opacity))
69 |
70 | (defun fill-opacity (opacity)
71 | (*pdf*.fillOpacity opacity))
72 |
73 | (defun opacity (opacity)
74 | (*pdf*.opacity opacity))
75 |
76 | (defun move-to (x y)
77 | (*pdf*.moveTo x y))
78 |
79 | (defun line-to (x y)
80 | (*pdf*.lineTo x y))
81 |
82 | (defun quadratic-curve-to (x1 y1 x2 y2)
83 | (*pdf*.quadraticCurveTo x1 y1 x2 y2))
84 |
85 | (defun bezier-curve-to (x1 y1 x2 y2 x3 y3)
86 | (*pdf*.bezierCurveTo x1 y1 x2 y2 x3 y3))
87 |
88 | (defun stroke (&optional color)
89 | (*pdf*.stroke color))
90 |
91 | (defun fill (&optional color)
92 | (*pdf*.fill color))
93 |
94 | (defun fill-and-stroke (&optional fill-color stroke-color)
95 | (*pdf*.fillAndStroke fill-color stroke-color))
96 |
97 | (defun save ()
98 | (*pdf*.save))
99 |
100 | (defun restore ()
101 | (*pdf*.restore))
102 |
103 | (export pdf new-page text font font-size down
104 | x y mm pt
105 | line-width
106 | stroke-color fill-color
107 | stroke-opacity fill-opacity
108 | opacity
109 | move-to line-to quadratic-curve-to bezier-curve-to
110 | stroke fill fill-and-stroke)
111 |
--------------------------------------------------------------------------------
/log.lisp:
--------------------------------------------------------------------------------
1 | (import * from gui)
2 | (import * from layout)
3 |
4 | (defun timestamp (x)
5 | (labels ((str (value n)
6 | (let ((res ~"0000{value}"))
7 | (slice res (- (length res) n)))))
8 | (let ((YYYY (str (x.getFullYear) 4))
9 | (MM (str (1+ (x.getMonth)) 2))
10 | (DD (str (x.getDate) 2))
11 | (hh (str (x.getHours) 2))
12 | (mm (str (x.getMinutes) 2))
13 | (ss (str (x.getSeconds) 2))
14 | (mss (str (x.getMilliseconds) 3)))
15 | ~"{YYYY}-{MM}-{DD} {hh}:{mm}:{ss}.{mss}")))
16 |
17 | (defvar *log* (list))
18 | (defvar *logwindow* null)
19 | (defvar *severity-colors* (list "#000000"
20 | "#800080"
21 | "#C00000"
22 | "#FF0000"))
23 |
24 | (defconstant INFO 0)
25 | (defconstant WARNING 1)
26 | (defconstant ERROR 2)
27 | (defconstant FATAL 3)
28 |
29 | (defun add-row (severity msg)
30 | (let ((x (create-element "div")))
31 | (set-style x
32 | color (aref *severity-colors* severity)
33 | whiteSpace "nowrap"
34 | fontFamily "Arial"
35 | px/fontSize 16
36 | fontWeight "bold"
37 | px/padding 1)
38 | (setf x.textContent msg)
39 | (append-child *logwindow*.data x)))
40 |
41 | (defun write (msg &key (severity 0))
42 | (let ((x (+ (timestamp (js-code "(new Date)")) " -- " msg)))
43 | (push (list severity x)
44 | *log*)
45 | (when *logwindow*
46 | (add-row severity x))))
47 |
48 | (defvar *x0* 100)
49 | (defvar *y0* 100)
50 | (defvar *width* 600)
51 | (defvar *height* 400)
52 |
53 | (defun show ()
54 | (unless *logwindow*
55 | (let* ((scroll (create-element "div"))
56 | (clear (button "Clear"
57 | (lambda ()
58 | (setf *log* (list))
59 | (do ()
60 | ((not scroll.firstChild))
61 | (remove-child scroll scroll.firstChild)))))
62 | (layout (V spacing: 8 border: 8
63 | (dom scroll)
64 | size: 30
65 | (H :filler: size: 80 (dom clear) :filler:))))
66 | (setf *logwindow* (window *x0* *y0* *width* *height*
67 | title: "Log window"))
68 | (set-style scroll
69 | position "absolute"
70 | backgroundColor "#EEE"
71 | overflow "auto")
72 | (set-style *logwindow*.client
73 | overflow "hidden")
74 | (append-child *logwindow*.client scroll)
75 | (append-child *logwindow*.client clear)
76 | (setf *logwindow*.data scroll)
77 | (map (lambda (x) (apply #'add-row x)) *log*)
78 | (setf *logwindow*.resize-cback
79 | (lambda (x0 y0 x1 y1)
80 | (set-coords layout 0 0 (- x1 x0) (- y1 y0))))
81 | (setf *logwindow*.close-cback
82 | (lambda ()
83 | (setf *x0* *logwindow*.frame.offsetLeft)
84 | (setf *y0* *logwindow*.frame.offsetTop)
85 | (setf *width* *logwindow*.frame.offsetWidth)
86 | (setf *height* *logwindow*.frame.offsetHeight)
87 | (setf *logwindow* null)))
88 | (show-window *logwindow*))))
89 |
90 | (export write show *log*
91 | INFO WARNING ERROR FATAL)
92 |
--------------------------------------------------------------------------------
/doctest.lisp:
--------------------------------------------------------------------------------
1 | (defun run ()
2 | (let ((tested (list))
3 | (skipped (list))
4 | (total 0)
5 | (failed 0)
6 | (glob (js-code "glob")))
7 | (dolist (n (keys glob))
8 | (when ((regexp "^[mf]([a-z0-9]|\\$[0-9]+_)*\\$\\$.*").exec n)
9 | (let ((f (aref glob n))
10 | (name (demangle n)))
11 | (if (callable? f)
12 | (when (and f.documentation
13 | (find "[[" f.documentation)
14 | (find ";; ==>" f.documentation))
15 | (push name tested)
16 | (let* ((doc f.documentation)
17 | (tstart (last-index "[[" f.documentation))
18 | (tend (last-index "]]" f.documentation))
19 | (test (slice doc (+ 2 tstart) tend)))
20 | (enumerate (num case (split test "\n\n"))
21 | (incf total)
22 | (let* ((err (find "\n**ERROR**: " case))
23 | (ix (if err
24 | (index "\n**ERROR**: " case)
25 | (index "\n;; ==> " case)))
26 | (src (strip (slice case 0 ix)))
27 | (reference (replace
28 | (strip (replace
29 | (if (find "\n**ERROR**: " case)
30 | "**ERROR**"
31 | (slice case (+ 8 (index "\n;; ==> " case))))
32 | "\n;;.*" ""))
33 | "\\n\\s+" " "))
34 | (result null)
35 | (out (list)))
36 | (let ((od #'display)
37 | (ow #'warning)
38 | (oa #'alert))
39 | (setf #'display (lambda (x) (push (list "d" x) out)))
40 | (setf #'warning (lambda (x) (push (list "w" x) out)))
41 | (setf #'alert (lambda (x) (push (list "a" x) out)))
42 | (let ((current-module *current-module*))
43 | (in-module (symbol-module (aref glob (+ "s" (slice n 1)))))
44 | (setf result (try
45 | (str-value (toplevel-eval
46 | (read src)))
47 | "**ERROR**"))
48 | (in-module current-module))
49 | (setf #'alert oa)
50 | (setf #'display od)
51 | (setf #'warning ow))
52 | (unless (= result reference)
53 | (incf failed)
54 | (alert ~"FAILURE: {name} ({(first n)}) test #{(1+ num)}\n\n\
55 | src={(json src)}\n\n\
56 | result={(json result)}\n\n\
57 | reference={(json reference)}"))))))
58 | (push name skipped)))))
59 | (display ~"total: {total} test cases")
60 | (display ~"failed: {failed}")
61 | (display ~"tested {(length tested)} functions/macros: {tested}")
62 | (display ~"skipped {(length skipped)}: {skipped}")))
63 |
64 | (export run)
--------------------------------------------------------------------------------
/gps.lisp:
--------------------------------------------------------------------------------
1 |
2 | (defun set-action (name precond to-remove to-add)
3 | (lambda (state)
4 | (when (subset precond state)
5 | (list name (set-union (set-difference state to-remove)
6 | to-add)))))
7 |
8 | (defun build-block-actions (blocks)
9 | (let ((actions (list)))
10 | (dolist (x blocks)
11 | (dolist (y blocks)
12 | (when (/= x y)
13 | (dolist (z blocks)
14 | (when (and (/= x z) (/= y z))
15 | (push (set-action ~"{x}-from-{y}-to-{z}"
16 | (list (intern ~"space-on-{x}")
17 | (intern ~"{x}-on-{y}")
18 | (intern ~"space-on-{z}"))
19 | (list (intern ~"{x}-on-{y}")
20 | (intern ~"space-on-{z}"))
21 | (list (intern ~"{x}-on-{z}")
22 | (intern ~"space-on-{y}")))
23 | actions)))
24 | (push (set-action ~"{x}-from-{y}-to-table"
25 | (list (intern ~"space-on-{x}")
26 | (intern ~"{x}-on-{y}"))
27 | (list (intern ~"{x}-on-{y}"))
28 | (list (intern ~"space-on-{y}")
29 | (intern ~"{x}-on-table")))
30 | actions)
31 | (push (set-action ~"{x}-from-table-to-{y}"
32 | (list (intern ~"space-on-{x}")
33 | (intern ~"space-on-{y}")
34 | (intern ~"{x}-on-table"))
35 | (list (intern ~"space-on-{y}")
36 | (intern ~"{x}-on-table"))
37 | (list (intern ~"{x}-on-{y}")))
38 | actions))))
39 | actions))
40 |
41 | (defun gps (start actions goal key)
42 | (do ((seen (let ((seen #()))
43 | (setf (aref seen (funcall key start)) (list "*start*" null))
44 | seen))
45 | (active (list start))
46 | (solution null))
47 | ((or solution
48 | (zero? (length active)))
49 | solution)
50 | (let ((next-active (list)))
51 | (dolist (state active)
52 | (if (funcall goal state)
53 | (progn
54 | (setf solution (list))
55 | (do ((x (list "*goal*" state)))
56 | ((null? (second x))
57 | (nreverse solution))
58 | (push x solution)
59 | (setf x (aref seen (funcall key (second x))))))
60 | (dolist (action actions)
61 | (let ((result (funcall action state)))
62 | (when (and result
63 | (undefined? (aref seen (funcall key (second result)))))
64 | (setf (aref seen (funcall key (second result)))
65 | (list (first result) state))
66 | (push (second result) next-active))))))
67 | (setf active next-active))))
68 |
69 | (let ((x (gps '(space-on-a
70 | a-on-c
71 | c-on-b
72 | b-on-table)
73 | (build-block-actions '(a b c))
74 | (lambda (s) (subset '(c-on-b b-on-a) s))
75 | (lambda (s) (+ (sort s) "")))))
76 | (if x
77 | (dolist (y x)
78 | (display (str-value y)))
79 | (display "** NO SOLUTION **")))
80 |
--------------------------------------------------------------------------------
/simpledb.lisp:
--------------------------------------------------------------------------------
1 | (defvar *transaction* (list))
2 | (defvar *changelog* (list))
3 | (defvar *tables* (list))
4 | (defvar *no-transactions* false)
5 |
6 | (defvar *logwrite* null)
7 |
8 | (defun commit ()
9 | (when *logwrite*
10 | (funcall *logwrite* (str-value `(progn ,@*changelog*) false)))
11 | (setf *changelog* (list))
12 | (setf *transaction* (list)))
13 |
14 | (defun rollback ()
15 | (setf *changelog* (list))
16 | (do () ((zero? (length *transaction*)))
17 | (funcall (pop *transaction*))))
18 |
19 | (defun dump (write-function)
20 | (dotimes (pass 2)
21 | (dolist (table *tables*)
22 | (let* ((colnames (keys (symbol-value table)))
23 | (cols (map (lambda (n)
24 | (aref (symbol-value table) n))
25 | colnames)))
26 | (if (= pass 0)
27 | (funcall write-function
28 | `(defrecord ,table ,(map #'intern colnames)))
29 | (dotimes (i (length (first cols)))
30 | (funcall write-function
31 | `(,#"new-{table}" ,@(map (lambda (j)
32 | (aref cols j i))
33 | (range (length colnames)))))))))))
34 |
35 | (defmacro defrecord (name fields)
36 | `(progn
37 | (unless (= 0 (length *transaction*) (length *changelog*))
38 | (error "Record type definition is not allowed in a transaction"))
39 | (when *logwrite*
40 | (funcall *logwrite* (str-value `(defrecord ,',name ,',fields) false)))
41 | (push ',name *tables*)
42 | (defvar ,name #(,@(map (lambda (f)
43 | `(,f (list)))
44 | fields)))
45 | (defun ,#"new-{name}" ,fields
46 | (let ((id (length (. ,name ,(first fields)))))
47 | ,@(map (lambda (f)
48 | `(push ,f (. ,name ,f)))
49 | fields)
50 | (unless *no-transactions*
51 | (push (lambda ()
52 | ,@(map (lambda (f)
53 | `(pop (. ,name ,f)))
54 | fields))
55 | *transaction*)
56 | (push (append (list ',#"new-{name}") (list ,@fields))
57 | *changelog*))
58 | (list ',name id)))
59 | (defun ,name (record)
60 | (list ',name record))
61 | ,@(map (lambda (f)
62 | `(defmethod ,f (record) (= (first record) ',name)
63 | (aref (. ,name ,f) (second record))))
64 | fields)
65 | ,@(map (lambda (f)
66 | `(defmethod ,#"set-{f}" (record value) (= (first record) ',name)
67 | (let* ((r (second record))
68 | (old-value (aref (. ,name ,f) r)))
69 | (unless *no-transactions*
70 | (push `(setf (aref (. ,',name ,',f) ,r) ',value)
71 | *changelog*)
72 | (push (lambda () (setf (aref (. ,name ,f) r) old-value))
73 | *transaction*)))
74 | (setf (aref (. ,name ,f) (second record)) value)))
75 | fields)
76 | (defmacro ,#"foreach-{name}" (var &rest body)
77 | (let ((rno (gensym)))
78 | `(dotimes (,rno (length (. ,',name ,',(first fields))))
79 | (let ((,var (list ',',name ,rno)))
80 | ,@body))))
81 | ',name))
82 |
83 | (export *logwrite* *tables* *no-transactions*
84 | defrecord
85 | commit rollback
86 | dump)
--------------------------------------------------------------------------------
/canvas.lisp:
--------------------------------------------------------------------------------
1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 | ;;; ;;;
4 | ;;; Copyright (c) 2011 by Andrea Griffini ;;;
5 | ;;; ;;;
6 | ;;; Permission is hereby granted, free of charge, to any person obtaining ;;;
7 | ;;; a copy of this software and associated documentation files (the ;;;
8 | ;;; "Software"), to deal in the Software without restriction, including ;;;
9 | ;;; without limitation the rights to use, copy, modify, merge, publish, ;;;
10 | ;;; distribute, sublicense, and/or sell copies of the Software, and to ;;;
11 | ;;; permit persons to whom the Software is furnished to do so, subject to ;;;
12 | ;;; the following conditions: ;;;
13 | ;;; ;;;
14 | ;;; The above copyright notice and this permission notice shall be ;;;
15 | ;;; included in all copies or substantial portions of the Software. ;;;
16 | ;;; ;;;
17 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;;
18 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;;
19 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;;
20 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE ;;;
21 | ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION ;;;
22 | ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION ;;;
23 | ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;;;
24 | ;;; ;;;
25 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27 |
28 | (defobject p2d (x y))
29 | (defmacro p2d (x y) `(new-p2d ,x ,y))
30 | (defmacro p2d-x (p) `(. ,p x))
31 | (defmacro p2d-y (p) `(. ,p y))
32 |
33 | (defun canvas (width height)
34 | (let ((canvas (create-element "canvas")))
35 | (setf canvas.width width)
36 | (setf canvas.height height)
37 | (setf canvas.style.width (+ width "px"))
38 | (setf canvas.style.height (+ height "px"))
39 | canvas))
40 |
41 | (defun box (canvas color x y w h)
42 | (let ((ctx (canvas.getContext "2d")))
43 | (setf ctx.fillStyle color)
44 | (funcall ctx.fillRect x y w h)))
45 |
46 | (defun polyline (canvas color pen-width pts)
47 | (let ((ctx (canvas.getContext "2d")))
48 | (setf ctx.strokeStyle color)
49 | (setf ctx.lineWidth pen-width)
50 | (ctx.beginPath)
51 | (ctx.moveTo (p2d-x (first pts)) (p2d-y (first pts)))
52 | (dolist (p (rest pts))
53 | (ctx.lineTo (p2d-x p) (p2d-y p)))
54 | (ctx.stroke)))
55 |
56 | (let ((canvas (canvas 200 200)))
57 | (box canvas "#FF0000" 0 0 200 200)
58 | (box canvas "#FFFF00" 5 5 190 190)
59 | (polyline canvas "#000000" 2
60 | (map (lambda (j)
61 | (let ((t (/ (* j 2 pi) 6)))
62 | (p2d (+ 100 (* 80 (cos t)))
63 | (+ 100 (* 80 (sin t))))))
64 | (range 7)))
65 | (setf canvas.style.position "absolute")
66 | (setf canvas.style.left "100px")
67 | (setf canvas.style.top "100px")
68 | (setf canvas.onclick (lambda () (remove-child document.body canvas)))
69 | (append-child document.body canvas))
70 |
--------------------------------------------------------------------------------
/animation.lisp:
--------------------------------------------------------------------------------
1 | (defstruct transition
2 | begin end old new)
3 |
4 | (defun smooth-interp (a b t)
5 | "Returns a smoothly interpolated value between a and b when t varies from 0 to 1"
6 | (cond
7 | ((<= t 0) a)
8 | ((>= t 1) b)
9 | (true (let ((w (- (* 3 t t) (* 2 t t t))))
10 | (+ (* a (- 1 w))
11 | (* b w))))))
12 |
13 | (defun var (value duration)
14 | "Creates an animated variable closure supporting value: set-value: set-duration: messages"
15 | (let ((transitions (list)))
16 | (labels ((fast-forward-to (now)
17 | (do ()
18 | ((or (empty transitions)
19 | (> (transition-end (first transitions)) now)))
20 | (setf value (transition-new (first transitions)))
21 | (splice transitions 0 1))))
22 | (lambda (msg &rest args)
23 | (cond
24 | ((= msg set-value:)
25 | (let ((now (clock))
26 | (new-value (first args)))
27 | (fast-forward-to now)
28 | (push (if (empty transitions)
29 | (make-transition begin: now
30 | end: (+ now duration)
31 | old: value
32 | new: new-value)
33 | (let ((lt (last transitions)))
34 | (make-transition begin: (transition-end lt)
35 | end: (+ (transition-end lt) duration)
36 | old: (transition-new lt)
37 | new: new-value)))
38 | transitions)
39 | new-value))
40 | ((= msg set-duration:)
41 | (setf duration (first args)))
42 | ((= msg value:)
43 | (let ((now (clock)))
44 | (fast-forward-to now)
45 | (unless (empty transitions)
46 | (let* ((ft (first transitions))
47 | (t (/ (- now (transition-begin ft))
48 | (- (transition-end ft)
49 | (transition-begin ft)))))
50 | (setf value (smooth-interp
51 | (transition-old ft)
52 | (transition-new ft)
53 | t))))
54 | value)))))))
55 |
56 | (defmacro var-access (x)
57 | "Current value of an animated variable"
58 | `(funcall ,x value:))
59 |
60 | (defmacro set-var-access (x y)
61 | "Sets long-term value of an animated variable by queueing a transition for it"
62 | `(funcall ,x set-value: ,y))
63 |
64 | (defmacro defanimated (name value duration)
65 | "Defines a global variable as animated"
66 | `(progn
67 | (defvar ,(intern ~"*animated-{name}*") (var ,value ,duration))
68 | (define-symbol-macro ,name (var-access ,(intern ~"*animated-{name}*")))))
69 |
70 | (defmacro animated-let (vars &rest body)
71 | "Evaluates body forms after lexically binding specified vars to animated values. Each element of vars is assumed to be a list (name start-value transition-duration)."
72 | (let ((animated (map (lambda (x) (gensym))
73 | (range (length vars)))))
74 | `(let (,@(let ((res (list))
75 | (i 0))
76 | (dolist (v vars)
77 | (push `(,(aref animated i)
78 | (var ,(second v) ,(third v)))
79 | res)
80 | (incf i))
81 | res))
82 | (symbol-macrolet (,@(let ((res (list))
83 | (i 0))
84 | (dolist (v vars)
85 | (push `(,(first v)
86 | (var-access ,(aref animated i)))
87 | res)
88 | (incf i))
89 | res))
90 | ,@body))))
91 |
--------------------------------------------------------------------------------
/chatserver.lisp:
--------------------------------------------------------------------------------
1 | (defun start-server (address port handler)
2 | (let* ((http (js-code "require('http')"))
3 | (server (http.createServer handler)))
4 | (server.listen port address)))
5 |
6 | (defun reply (response content-type msg)
7 | (response.writeHead 200 #((Content-type content-type)))
8 | (response.end msg))
9 |
10 | (defobject channel (name
11 | (n0 0)
12 | (max 100)
13 | (messages (list))
14 | (listeners (list))))
15 |
16 | (defun add-message (channel message)
17 | (display ~"{channel}: + {(str-value message)}")
18 | (push message channel.messages)
19 | (let ((xs (- (length channel.messages) channel.max)))
20 | (when (> xs 0)
21 | (incf channel.n0 xs)
22 | (setf channel.messages (slice channel.messages xs)))))
23 |
24 | (defvar *channels* #())
25 |
26 | (defun channel (x)
27 | "Returns a channel given its name [x] or creates a new channel"
28 | (or (aref *channels* x)
29 | (setf (aref *channels* x) (new-channel x))))
30 |
31 | (defun send (response channel-name message)
32 | "Send a [message] to the specified [channel]"
33 | (let ((channel (channel channel-name)))
34 | (add-message channel message)
35 | (let ((id (+ channel.n0 (length channel.messages) -1)))
36 | (reply response "text/plain" ~"OK:{id}")
37 | (dolist (x channel.listeners)
38 | (reply x "text/plain" ~"{id}:{message}"))
39 | (setf channel.listeners (list)))))
40 |
41 | (defun receive (response channel-name after)
42 | "Receive all messages from [channel] after the specified number"
43 | (let* ((channel (channel channel-name))
44 | (messages channel.messages)
45 | (skip (max 0 (- (read after) channel.n0))))
46 | (if (< skip (length messages))
47 | (let ((reply (list)))
48 | (do ((id (+ channel.n0 skip) (1+ id))
49 | (i skip (1+ i)))
50 | ((>= i (length messages))
51 | (reply response "text/plain" (join reply "\n")))
52 | (push ~"{id}:{(aref messages i)}" reply)))
53 | (push response channel.listeners))))
54 |
55 | (defun handler (request response)
56 | (let ((url request.url)
57 | (parms "")
58 | (data ""))
59 | (when (find "?" url)
60 | (let ((i (index "?" url)))
61 | (setf parms (slice url (1+ i)))
62 | (setf url (slice url 0 i))))
63 | (let ((f (symbol-function (intern (slice url 1)))))
64 | (if f
65 | (if (= request.method "POST")
66 | (progn
67 | ;; A "POST" request requires data collection
68 | (request.on "data" (lambda (chunk)
69 | (incf data chunk)))
70 | (request.on "end" (lambda ()
71 | ;; Pass received data as last parameter
72 | (apply f (append (list response)
73 | (map #'uri-decode (split parms "&"))
74 | data)))))
75 | ;; "GET" request, just call the function
76 | (apply f (append (list response)
77 | (map #'uri-decode (split parms "&")))))
78 | (let ((content (try (get-file (+ "." url) null)
79 | (str-value *exception*)))
80 | (ctype (cond
81 | ((find ".html" url)
82 | "text/html")
83 | ((find ".css" url)
84 | "text/css")
85 | ((find ".js" url)
86 | "text/javascript")
87 | ((find ".jpg" url)
88 | "image/jpeg")
89 | ((find ".png" url)
90 | "image/png")
91 | (true "text/plain"))))
92 | (reply response ctype content))))))
93 |
94 | (start-server "127.0.0.1" 1337
95 | #'handler)
96 |
--------------------------------------------------------------------------------
/autodep.lisp:
--------------------------------------------------------------------------------
1 | (defun spawn (command arguments stdout stderr exit)
2 | "Starts a new process executing [command] passing specified [arguments],
3 | calling [stdout]/[stderr] functions for any output produced and
4 | calling [exit] function with the return code."
5 | (let* ((spawn (js-code "require('child_process').spawn"))
6 | (cmd (funcall spawn command arguments)))
7 | (cmd.stdout.on "data" stdout)
8 | (cmd.stderr.on "data" stderr)
9 | (cmd.on "exit" exit)
10 | cmd))
11 |
12 | (defun main ()
13 | (let ((output "")
14 | (sources #())
15 | (targets #()))
16 | (spawn "find" (list "." "-name" "*.lisp")
17 | (lambda (out)
18 | (incf output (out.toString)))
19 | (lambda (err)
20 | (error ~"STDERR: {(err.toString)}"))
21 | (lambda (code)
22 | (unless (= code 0)
23 | (error ~"Invalid return code {code}"))
24 | (let ((files (map (lambda (x) (slice x 2))
25 | (filter #'length (split output "\n")))))
26 | (dolist (f files)
27 | (display ~"Analyzing {f}")
28 | ;; Analysis is performed by a mixture of text search
29 | ;; and parsing because of the problem of user-defined
30 | ;; reader macros. It's assumed that no reader macro is
31 | ;; used in an import form and that there's no space
32 | ;; between the open parenthesis and "import".
33 | (let ((srctext (get-file f)))
34 | (do ((i0 -1 i)
35 | (i (index "(import " srctext) (index "(import " srctext (1+ i0))))
36 | ((= i -1))
37 | (labels ((add-dep (target source)
38 | (push target (or (aref targets source)
39 | (setf (aref targets source) (list))))
40 | (push source (or (aref sources target)
41 | (setf (aref sources target) (list))))))
42 | (try (let ((x (read (slice srctext i))))
43 | (cond
44 | ;; (import [as ])
45 | ((and (or (= (length x) 2)
46 | (and (= (length x) 4) (= (third x) 'as)))
47 | (symbol? (second x)))
48 | (let ((mname (+ (symbol-name (second x)) ".lisp")))
49 | (when (find mname files)
50 | (add-dep f mname))))
51 | ;; (import ... from [as ])
52 | ((and (or (and (= (length x) 4)
53 | (= (aref x 2) 'from)
54 | (symbol? (aref x 3)))
55 | (and (= (length x) 6)
56 | (= (aref x 2) 'from)
57 | (= (aref x 4) 'as)
58 | (symbol? (aref x 3)))))
59 | (let ((mname (+ (symbol-name (aref x 3)) ".lisp")))
60 | (when (find mname files)
61 | (add-dep f mname))))))
62 | (display ~"parse error ignored"))))))
63 | (display "\nGenerating Makefile")
64 | (let ((res ""))
65 | (dolist (target (keys sources))
66 | (let ((base (slice target 0 -5)))
67 | (incf res ~"{base}.html:")
68 | (dolist (source (aref sources target))
69 | (incf res ~" {source}"))
70 | (incf res ~"\n\tnode jslisp.js deploy-html.lisp {target} > {base}.html\n\n")))
71 | (js-code "require('fs').writeFile('Makefile',d$$res)")))))))
72 |
73 | (main)
--------------------------------------------------------------------------------
/fsg.lisp:
--------------------------------------------------------------------------------
1 | (defvar *screen* (create-element "div"))
2 | (setf (. *screen* style position) "absolute")
3 | (setf (. *screen* style left) "0px")
4 | (setf (. *screen* style right) "0px")
5 | (setf (. *screen* style top) "0px")
6 | (setf (. *screen* style bottom) "0px")
7 | (setf (. *screen* style overflow) "hidden")
8 | (setf (. *screen* style pointerEvents) "none")
9 | (append-child (. document body) *screen*)
10 | (defvar *canvas* (create-element "canvas"))
11 | (append-child *screen* *canvas*)
12 | (setf (. *canvas* style pointerEvents) "none")
13 | (defvar *dc* (funcall (. *canvas* getContext) "2d"))
14 |
15 | (defun clear ()
16 | "Clears all graphics"
17 | (setf (. *canvas* width) (. *screen* offsetWidth))
18 | (setf (. *canvas* height) (. *screen* offsetHeight))
19 | null)
20 |
21 | (defun fill-style (s)
22 | "Sets current fill style"
23 | (setf (. *dc* fillStyle) s))
24 |
25 | (defun stroke-style (s)
26 | "Sets current stroke style"
27 | (setf (. *dc* strokeStyle) s))
28 |
29 | (defun line-width (s)
30 | "Sets current line width"
31 | (setf (. *dc* lineWidth) s))
32 |
33 | (defmacro defgfx (lisp-name doc js-name &rest args)
34 | `(defun ,lisp-name ,args ,doc (funcall (. *dc* ,js-name) ,@args)))
35 |
36 | (defgfx begin-path
37 | "Starts a new path"
38 | beginPath)
39 |
40 | (defgfx close-path
41 | "Closes current path by connecting current point to start point"
42 | closePath)
43 |
44 | (defgfx move-to
45 | "Moves the current point to (x, y)"
46 | moveTo x y)
47 |
48 | (defgfx line-to
49 | "Draws a line from current point to (x, y)"
50 | lineTo x y)
51 |
52 | (defgfx bez2-to
53 | "Draws a quadratic bezier from current point, using control point (x1, y1) and arriving to (x2, y2)"
54 | quadraticCurveTo x1 y1 x2 y2)
55 |
56 | (defgfx bez3-to
57 | "Draws a cubic bezier from current point, using control points (x1, y1), (x2, y2) and arriving to (x3, y3)"
58 | bezierCurveTo x1 y1 x2 y2 x3 y3)
59 |
60 | (defgfx arc-to
61 | "?"
62 | arcTo x1 y1 x2 y2 radius)
63 |
64 | (defgfx arc
65 | "Draws and arc with center (x, y), radius r, starting angle a0 and
66 | ending angle a1. Parameter ccw decides if the arc should be
67 | drawn counterclockwise (true) or clockwise (false)."
68 | arc x y r a0 a1 ccw)
69 |
70 | (defgfx fill
71 | "Fills current path (eventually by first closing it) with current fill style"
72 | fill)
73 |
74 | (defgfx stroke
75 | "Draws the boundary of current path with current stroke style and line width"
76 | stroke)
77 |
78 | (defgfx clip
79 | "Clips subsequent draw operations to current path"
80 | clip)
81 |
82 | (defgfx fill-rect
83 | "Fills a rectangle with current fill style"
84 | fillRect x0 y0 w h)
85 |
86 | (defun random-color ()
87 | "Returns a random color"
88 | (let ((red (+ 128 (random-int 64)))
89 | (green (+ 128 (random-int 64)))
90 | (blue (+ 128 (random-int 64))))
91 | ~"rgb({red},{green},{blue})"))
92 |
93 | (defun font (x)
94 | (setf (. *dc* font) x))
95 |
96 | (defgfx fill-text
97 | "Draws the specified text using current fill style"
98 | fillText text x y)
99 |
100 | (defgfx stroke-text
101 | "Draws the specified text using current stroke style"
102 | strokeText text x y)
103 |
104 | (defun text-width (text)
105 | "Width of a text line"
106 | (. (funcall (. *dc* measureText) text) width))
107 |
108 | (defun save ()
109 | "Saves graphic context status"
110 | (funcall (. *dc* save)))
111 |
112 | (defun restore ()
113 | "Restores graphic context status"
114 | (funcall (. *dc* restore)))
115 |
116 | (defun shadow (color dx dy blur)
117 | (setf (. *dc* shadowColor) color)
118 | (setf (. *dc* shadowOffsetX) dx)
119 | (setf (. *dc* shadowOffsetY) dy)
120 | (setf (. *dc* shadowBlur) blur))
121 |
122 | (clear)
123 |
124 | (export *screen* *canvas* *dc*
125 | clear fill-style stroke-style line-width
126 | begin-path close-path
127 | move-to line-to bez-2 bez-3 arc-to arc
128 | fill stroke clip
129 | fill-rect
130 | random-color
131 | font fill-text stroke-text text-width
132 | save restore
133 | shadow)
--------------------------------------------------------------------------------
/examples/gridclient.lisp:
--------------------------------------------------------------------------------
1 | (import * from gui)
2 | (import * from rpc-client)
3 | (import * from examples/pdfgrid)
4 |
5 | (defun mm (x)
6 | (* x (/ 72 25.4)))
7 |
8 | (defun parmform ()
9 | (let ((screen (create-element "div"))
10 | (width 500)
11 | (height 400))
12 | (set-style screen
13 | position "absolute"
14 | px/left 0
15 | px/top 0
16 | px/right 0
17 | px/bottom 0)
18 | (append-child document.body screen)
19 | (with-window (w ((/ (- screen.offsetWidth width) 2)
20 | (/ (- screen.offsetHeight height) 2)
21 | width height
22 | title: "PDF grid")
23 | ((page-width (input "Page width (mm)"))
24 | (page-height (input "Page height (mm)"))
25 | (rows (input "Number of rows"))
26 | (cols (input "Number of columns"))
27 | (left (input "Left margin (mm)"))
28 | (top (input "Top margin (mm)"))
29 | (x-step (input "Horizontal distance (mm)"))
30 | (y-step (input "Vertical distance (mm)"))
31 | (fontsize (input "Font size (mm)"))
32 | (text (input "Text"))
33 | (ok (button "OK"
34 | (lambda ()
35 | (let ((page-width (atof (text page-width)))
36 | (page-height (atof (text page-height)))
37 | (rows (atoi (text rows)))
38 | (cols (atoi (text cols)))
39 | (left (atof (text left)))
40 | (top (atof (text top)))
41 | (x-step (atof (text x-step)))
42 | (y-step (atof (text y-step)))
43 | (fontsize (atof (text fontsize)))
44 | (text (text text)))
45 | (unless (any (x (list page-width page-height
46 | rows cols
47 | left top
48 | x-step y-step
49 | fontsize))
50 | (NaN? x))
51 | (let ((result
52 | (grid text (mm fontsize)
53 | (mm page-width) (mm page-height)
54 | rows cols
55 | (mm left) (mm top)
56 | (mm x-step) (mm y-step))))
57 | (setf document.location result)))))))
58 | (cancel (button "Cancel" (lambda () (hide-window w)))))
59 | (V: spacing: 16 border: 16
60 | (H: size: 30
61 | (Hdiv: page-width)
62 | (Hdiv: page-height))
63 | (H: size: 30
64 | (Hdiv: rows)
65 | (Hdiv: cols))
66 | (H: size: 30
67 | (Hdiv: left)
68 | (Hdiv: top))
69 | (H: size: 30
70 | (Hdiv: x-step)
71 | (Hdiv: y-step))
72 | (H: size: 30
73 | (Hdiv: fontsize)
74 | (Hdiv: text))
75 | (H:)
76 | (H: size: 30
77 | (H:)
78 | (Hdiv: ok size: 80)
79 | (Hdiv: cancel size: 80)
80 | (H:))))
81 | (show-window w)
82 | (set-timeout (lambda () (page-width.lastChild.focus)) 100))))
83 |
84 | (defun main ()
85 | (parmform))
86 |
87 | (main)
--------------------------------------------------------------------------------
/uichessboard.lisp:
--------------------------------------------------------------------------------
1 | (defun make-chessboard (x y sqsz)
2 | (let ((board (sprite *root*
3 | (begin-path)
4 | (move-to (* -4.125 sqsz) (* -4.125 sqsz))
5 | (line-to (* 4.125 sqsz) (* -4.125 sqsz))
6 | (line-to (* 4.125 sqsz) (* 4.125 sqsz))
7 | (line-to (* -4.125 sqsz) (* 4.125 sqsz))
8 | (close-path)
9 | (fill "#808080")
10 | (begin-path)
11 | (move-to (* -4 sqsz) (* -4 sqsz))
12 | (line-to (* 4 sqsz) (* -4 sqsz))
13 | (line-to (* 4 sqsz) (* 4 sqsz))
14 | (line-to (* -4 sqsz) (* 4 sqsz))
15 | (close-path)
16 | (fill "#C08040"))))
17 | (dotimes (y 8)
18 | (dotimes (j 4)
19 | (let ((x (+ (* j 2) (logand y 1))))
20 | (add-graphics board
21 | (begin-path)
22 | (move-to (* (- x 4) sqsz) (* (- y 4) sqsz))
23 | (line-to (* (- x 3) sqsz) (* (- y 4) sqsz))
24 | (line-to (* (- x 3) sqsz) (* (- y 3) sqsz))
25 | (line-to (* (- x 4) sqsz) (* (- y 3) sqsz))
26 | (close-path)
27 | (fill "#E0C0A0")))))
28 | (let ((sq (list (list "r" "n" "b" "q" "k" "b" "n" "r")
29 | (list "p" "p" "p" "p" "p" "p" "p" "p")
30 | (list "." "." "." "." "." "." "." ".")
31 | (list "." "." "." "." "." "." "." ".")
32 | (list "." "." "." "." "." "." "." ".")
33 | (list "." "." "." "." "." "." "." ".")
34 | (list "P" "P" "P" "P" "P" "P" "P" "P")
35 | (list "R" "N" "B" "Q" "K" "B" "N" "R"))))
36 | (dotimes (y 8)
37 | (dotimes (x 8)
38 | (let ((c [[sq y] x]))
39 | (if (= c ".")
40 | (setf [[sq y] x] null)
41 | (let ((s (sprite board))
42 | (xx x)
43 | (yy y))
44 | (load-image s ~"{c}.png" 0 0)
45 | (setf [[sq yy] xx] s)
46 | (scale s (/ sqsz 150))
47 | (translate s
48 | (* (- xx 3.5) sqsz)
49 | (* (- yy 3.5) sqsz))
50 | (labels ((ijmap (x y)
51 | (let* ((rp (revxform x y (total-matrix board)))
52 | (i (+ 4 (floor (/ (first rp) sqsz))))
53 | (j (+ 4 (floor (/ (second rp) sqsz)))))
54 | (list i j))))
55 | (let ((tx null)
56 | (ty null))
57 | (setf s.hit
58 | (lambda (sx sy mode)
59 | (let* ((rp (revxform sx sy (total-matrix s.parent)))
60 | (x (first rp))
61 | (y (second rp)))
62 | (cond
63 | ((= mode 0)
64 | (set-parent s s.parent)
65 | (setf tx x)
66 | (setf ty y))
67 | ((= mode 1)
68 | (translate s (- x tx) (- y ty))
69 | (setf tx x)
70 | (setf ty y))
71 | (true
72 | (let* ((ij (ijmap sx sy))
73 | (i (first ij))
74 | (j (second ij)))
75 | (set-translation s (* (- i 3.5) sqsz) (* (- j 3.5) sqsz))
76 | (setf [[sq yy] xx] null)
77 | (when [[sq j] i]
78 | (set-parent [[sq j] i] null))
79 | (setf [[sq j] i] s)
80 | (setf xx i)
81 | (setf yy j)))))))))))))))
82 | (setf board.hit (drag board))
83 | (translate board x y)
84 | board))
85 |
--------------------------------------------------------------------------------
/turtle.lisp:
--------------------------------------------------------------------------------
1 | (load (http-get "fsg.lisp"))
2 |
3 | (defvar *turtle* (create-element "img"))
4 | (setf *turtle*.src "turtle.png")
5 | (setf *turtle*.style.position "absolute")
6 | (setf *turtle*.style.WebkitTransformOrigin "21px 16px")
7 | (append-child document.body *turtle*)
8 |
9 | (defvar *target-x* 200)
10 | (defvar *target-y* 200)
11 | (defvar *target-angle* 0)
12 | (defvar *turtle-x* 199)
13 | (defvar *turtle-y* 200)
14 | (defvar *turtle-angle* 0)
15 | (defvar *turtle-speed* 0.1)
16 | (defvar *turtle-last-update* (clock))
17 | (defvar *turtle-commands* (list))
18 | (defvar *turtle-pen* null)
19 |
20 | (set-interval (lambda (&rest args)
21 | (let* ((t (clock))
22 | (dt (- t *turtle-last-update*))
23 | (moved false)
24 | (oldx *turtle-x*)
25 | (oldy *turtle-y*))
26 | (setf *turtle-last-update* t)
27 | (if (/= *turtle-angle* *target-angle*)
28 | (let ((da (* *turtle-speed* dt)))
29 | (setf moved true)
30 | (if (< *target-angle* *turtle-angle*)
31 | (when (< (decf *turtle-angle* da) *target-angle*)
32 | (setf *turtle-angle* *target-angle*))
33 | (when (> (incf *turtle-angle* da) *target-angle*)
34 | (setf *turtle-angle* *target-angle*))))
35 | (let* ((dx (- *target-x* *turtle-x*))
36 | (dy (- *target-y* *turtle-y*))
37 | (L (sqrt (+ (* dx dx) (* dy dy))))
38 | (s (* *turtle-speed* dt)))
39 | (when (> L 0)
40 | (setf moved true)
41 | (if (> s L)
42 | (progn
43 | (setf *turtle-x* *target-x*)
44 | (setf *turtle-y* *target-y*))
45 | (let ((k (/ s L)))
46 | (incf *turtle-y* (* k dy))
47 | (incf *turtle-x* (* k dx)))))))
48 | (if moved
49 | (progn
50 | (setf *turtle*.style.WebkitTransform
51 | ~"translatex({(- *turtle-x* 21)}px) translatey({(- *turtle-y* 16)}px) rotate({*turtle-angle*}deg)")
52 | (when *turtle-pen*
53 | (begin-path)
54 | (move-to oldx oldy)
55 | (line-to *turtle-x* *turtle-y*)
56 | (stroke-style *turtle-pen*)
57 | (stroke)))
58 | (when (> (length *turtle-commands*) 0)
59 | (funcall (first (splice *turtle-commands* 0 1)))))))
60 | 20)
61 |
62 | (defmacro defcommand (name args &rest body)
63 | (let ((doc (list)))
64 | (when (string? (first body))
65 | (setf doc (splice body 0 1)))
66 | `(defun ,name ,args ,@doc (push (lambda () ,@body) *turtle-commands*) 'Ok)))
67 |
68 | (defcommand left (x)
69 | "Turns the turtle x degrees to the left"
70 | (decf *target-angle* x))
71 |
72 | (defcommand right (x)
73 | "Turns the turtle x degrees to the right"
74 | (incf *target-angle* x))
75 |
76 | (defcommand move (x)
77 | "Advances the turtle the specified number of pixels"
78 | (let ((a (* (/ pi 180) *target-angle*)))
79 | (incf *target-x* (* x (cos a)))
80 | (incf *target-y* (* x (sin a)))))
81 |
82 | (defcommand up ()
83 | "Stops leaving a colored trail"
84 | (setf *turtle-pen* null))
85 |
86 | (defmacro colors (&rest colors)
87 | `(progn ,@(let ((res (list)))
88 | (dolist (c colors)
89 | (push `(defcommand ,(second c) ()
90 | ,~"Starts leaving a {(second c)} trail"
91 | (setf *turtle-pen* ,(first c)))
92 | res))
93 | res)))
94 |
95 | (colors ("#000000" black)
96 | ("#FF0000" red)
97 | ("#00FF00" green)
98 | ("#FFFF00" yellow)
99 | ("#0000FF" blue)
100 | ("#FF00FF" magenta)
101 | ("#00FFFF" cyan)
102 | ("#FFFFFF" white)
103 | ("#888888" gray))
104 |
--------------------------------------------------------------------------------
/repl.txt:
--------------------------------------------------------------------------------
1 | *1 JsLisp
2 |
3 | = JsLisp
4 | The Read Eval Print Loop
5 |
6 | *2 Browser
7 |
8 | JsLisp REPL user interface runs in
9 | a browser and is implemented as a
10 | single textarea element.
11 |
12 | Usual cut/copy/paste commands can
13 | be used freely.
14 |
15 | *2 Expression evaluation
16 |
17 | When [ENTER] is pressed with the cursor
18 | at the very end of the textarea and if
19 | parenthesis are balanced then JsLisp
20 | evaluates and displays the result of
21 | what was present after the last result.
22 |
23 | *3 Goodies
24 |
25 | JsLisp REPL provides some help for
26 | entering JsLisp code:
27 |
28 | - Parenthesis matching
29 | - Autoindenting
30 | - Word autocompletion
31 | - Documentation lookup
32 |
33 | *3.1.1
34 | = Parenthesis matching
35 | ))))) 42))))))) T)))
36 |
37 | *3.1.2 Parenthesis matching
38 |
39 | Whenever the cursor is right after a closed
40 | parenthesis [")"] the corresponding open
41 | parenthesis is highlighted with a small red
42 | rectangle.
43 |
44 | Matching is always active, not only after
45 | the last prompt. Matching knows about simple
46 | quoted strings but not about interpolated
47 | strings and reader macros in general.
48 |
49 | *3.2.1
50 | = Autoindenting
51 | in the ONLY correct way ;-)
52 |
53 | *3.2.2 Autoidenting
54 |
55 | When pressing [ENTER] the REPL auto-indents
56 | next line placing the cursor where it will
57 | most probably start next typing.
58 |
59 | The rules are quite simple and there are no
60 | hardcoded forms in the REPL.
61 |
62 | *3.2.3 Autoindenting rules (1)
63 | == 1: nested lists
64 | When an open parenthesis follows an open
65 | parenthesis (nested lists like for [(let ...)]
66 | forms) then the list elements are aligned
67 | one character to the right in respect of
68 | the containing list.
69 |
70 | [[Let example
71 | (let ((x 10)
72 | (y 20)))
73 | ]]
74 |
75 | *3.2.4 Autoidenting rules (2)
76 | == 2: regular forms
77 | When the list looks like a regular form then
78 | elements are aligned to where the [second]
79 | element (i.e. the first parameter) was started.
80 |
81 | [[Normal form example
82 | (draw-circle (/ (+ x1 x2) 2)
83 | (/ (+ y1 y2) 2)
84 | radius)
85 | ]]
86 |
87 | *3.2.5 Autoindenting rules (3)
88 | == 3: [(... &rest body)]
89 | When the function or macro however has a
90 | [&rest] parameter with name [body] then
91 | all [body] elements will be indented
92 | two spaces to the right of containing form:
93 |
94 | [[Special forms
95 | (defun square ;; Function name
96 | (x) ;; Argument list
97 | (display "!") ;; Body form 1
98 | (* x x)) ;; Body form 2
99 | ]]
100 |
101 | *4.1 Word autocompletion
102 | = Autocom[pletion]
103 |
104 | *4.1 Autocompletion (1)
105 | Typing [ALT-/] invokes word autocompletion
106 | filtering on the preceding characters and
107 | proposes a first completion.
108 |
109 | Typing [ALT-/] again cycles on selected
110 | words, [Backspace] aborts and any other
111 | character accepts the completion.
112 |
113 | *4.2 Autocompletion (2)
114 | Words matching the already typed characters
115 | are proposed in the following order:
116 |
117 | - Backward from cursor to begin of textarea
118 | - Forward from cursor to end of textarea
119 | - All defined or imported words
120 |
121 | *5.1 Documentation lookup (1)
122 | JsLisp implements docstrings for function
123 | and macro documentation.
124 |
125 | The documentation is automatically shown
126 | in the REPL and appears in the top-right
127 | corner every time the cursor is standing
128 | in a documented form after a small delay.
129 |
130 | *5.2 Documentation lookup (2)
131 | The docstring is displayed as is, with
132 | the exception of text surrounded by
133 | square brackets that is displayed in
134 | bold and monospace.
135 |
136 | The argument list is always available
137 | and added to any explicit docstring.
138 | Typing [ESC] hides the display.
139 |
140 | *6 Warning
141 | = WARNING
142 |
143 | *6.1 It's just a textarea
144 | == It's just a [