├── demo ├── alist.pdf ├── alist.png └── slime-screenshot.png ├── package.lisp ├── visual-cells.asd ├── src ├── visual-cells.el └── visual-cells.lisp └── README.md /demo/alist.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cuichaox/visual-cells/HEAD/demo/alist.pdf -------------------------------------------------------------------------------- /demo/alist.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cuichaox/visual-cells/HEAD/demo/alist.png -------------------------------------------------------------------------------- /demo/slime-screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cuichaox/visual-cells/HEAD/demo/slime-screenshot.png -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | 3 | (defpackage #:visual-cells 4 | (:use :cl :cl-cairo2) 5 | (:export :fvs)) 6 | -------------------------------------------------------------------------------- /visual-cells.asd: -------------------------------------------------------------------------------- 1 | ;;;; visual-cells.asd 2 | 3 | (asdf:defsystem #:visual-cells 4 | :description "Display Lisp S-exp as tree of cons cells in a cario surface(pdf+png)." 5 | :author "cuichao " 6 | :license "Specify license here" 7 | :serial t 8 | :depends-on (#:cl-cairo2) 9 | :components ((:file "package") 10 | (:file "src/visual-cells"))) 11 | -------------------------------------------------------------------------------- /src/visual-cells.el: -------------------------------------------------------------------------------- 1 | ;; function to call by emacs 2 | (defun visual-exp () 3 | (interactive) 4 | (slime-eval `(swank:eval-and-grab-output 5 | ,(concat "(visual-cells::fvs '" 6 | (slime-last-expression) 7 | "\"/tmp/vs.out\")"))) 8 | (let* ((o-buffer-name "*visual-cells-output*") 9 | (o-buffer (get-buffer o-buffer-name))) 10 | (when o-buffer (kill-buffer o-buffer)) 11 | (find-file-read-only-other-window "/tmp/vs.out.png") 12 | (rename-buffer "*visual-cells-output*"))) 13 | ;; set key binding for slime mode 14 | (global-auto-revert-mode 1) 15 | (add-hook 'slime-mode-hook 16 | '(lambda () 17 | (define-key slime-mode-map "\C-cv" 'visual-exp))) 18 | 19 | 20 | 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # visual-cells 2 | Display Lisp S-exp as tree of cons cells in a cario surface(pdf+png). 3 | 4 | Quick Guide 5 | === 6 | Download File 'src/visual-cells.lisp' in this repository. put it in current directory.
7 | Load 'visual-cells.lisp' to your lisp image. For example : 8 | ```lisp 9 | (load "visual-cells.lisp") 10 | (visual-cells:fvs '((a . 1) (b . 2) (c . 3)) "alist") 11 | ``` 12 | alist.png
13 | ![alist.png](https://raw.githubusercontent.com/cuichaox/visual-cells/master/demo/alist.png) 14 | 15 | Call visual-cells in Slime 16 | === 17 | Add following line to your common lisp startup script. (eg. ~/.sbclrc)
18 | ```lisp 19 | (load "/path-to/visual-cells.lisp") ; Change "/path-to/" to your directory. 20 | ``` 21 | Add following lines to your emacs startup file.(eg. ~/.emacs)
22 | 23 | ```lisp 24 | ;; function to call by emacs 25 | (defun visual-exp () 26 | (interactive) 27 | (slime-eval `(swank:eval-and-grab-output 28 | ,(concat "(visual-cells::fvs '" 29 | (slime-last-expression) 30 | "\"/tmp/vs.out\")"))) 31 | (let* ((o-buffer-name "*visual-cells-output*") 32 | (o-buffer (get-buffer o-buffer-name))) 33 | (when o-buffer (kill-buffer o-buffer)) 34 | (find-file-read-only-other-window "/tmp/vs.out.png") 35 | (rename-buffer "*visual-cells-output*"))) 36 | ;; set key binding for slime mode 37 | (global-auto-revert-mode 1) 38 | (add-hook 'slime-mode-hook 39 | '(lambda () 40 | (define-key slime-mode-map "\C-cv" 'visual-exp))) 41 | ``` 42 | Start your Emacs and run slime, Open a lisp file.
43 | Move the point to end of a s-expresion, press "Ctrl+C V", the graphical display of the s-expression will open in Eamcs .
44 | ![slime-screenshot.png](https://raw.githubusercontent.com/cuichaox/visual-cells/master/demo/slime-screenshot.png) 45 | 46 | Todo 47 | === 48 | Specific topology and style for more Lisp data type, such as Hash, Alist, Plist etc. 49 | -------------------------------------------------------------------------------- /src/visual-cells.lisp: -------------------------------------------------------------------------------- 1 | ;; visual-cells.lisp 2 | (in-package :visual-cells) 3 | 4 | ;;tool maccro to ignore stle warning of cffi 5 | (defun ignore-warning (condition) 6 | (declare (ignore condition)) 7 | (muffle-warning)) 8 | (defmacro igw (&rest forms) 9 | `(handler-bind ((warning #'ignore-warning)) 10 | ,@forms)) 11 | 12 | ;; draw functions 13 | (defun draw-text-node(x y name &key label ) 14 | (let* ((n-exts (igw (get-text-extents name))) 15 | (n-width (text-width n-exts)) 16 | (n-height (text-height n-exts)) 17 | (n-x-offset (+ (text-x-bearing n-exts) (/ n-width 2))) 18 | (n-y-offset (+ (text-y-bearing n-exts) (/ n-height 2))) 19 | (n-radius (/ (sqrt (+ (expt n-width 2) (expt n-height 2))) 1.8))) 20 | (move-to (- x n-x-offset) (- y n-y-offset)) 21 | (show-text name) 22 | 23 | (new-path) 24 | (arc x y n-radius 0 (* 2.0 PI)) 25 | (save) 26 | (set-line-width (* 4 (get-line-width))) 27 | (stroke) 28 | (restore) 29 | (when label 30 | (save) 31 | (set-font-size (/ (trans-matrix-xx (igw (get-font-matrix))) 2)) 32 | (let* ((l-exts (igw (get-text-extents label))) 33 | (l-width (text-width l-exts)) 34 | (l-x-offset (+ (text-x-bearing l-exts) (/ l-width 2))) 35 | (l-y-offset (- (text-y-bearing l-exts) (* 7/5 n-radius)))) 36 | (move-to (- x l-x-offset) (- y l-y-offset)) 37 | (show-text label)) 38 | (restore)) 39 | n-radius)) 40 | 41 | (defun draw-atom (x y obj) 42 | (let ((name (typecase obj 43 | (integer "In") 44 | (float "Fl") 45 | (number "Nu") 46 | (keyword "Ke") 47 | (symbol "Sy") 48 | (string "St") 49 | (array "Ar") 50 | (character "Ch") 51 | (t "T"))) 52 | (label (format nil "~A" obj))) 53 | (draw-text-node x y name :label label))) 54 | 55 | ;;radius of Current Font 56 | (defun get-font-radius () 57 | (let* ((fm (igw (get-font-matrix))) 58 | (xx (trans-matrix-xx fm)) 59 | (yy (trans-matrix-yy fm))) 60 | (/ (sqrt (+ (expt xx 2) (expt yy 2)))2.2))) 61 | 62 | ;;draw cons cell node 63 | (defun draw-cons-node(x y) 64 | (let ((radius (get-font-radius))) 65 | (new-path) 66 | (arc x y radius 0 (* PI 2)) 67 | (save) 68 | (set-line-width (* 4 (get-line-width))) 69 | (stroke) 70 | (restore) 71 | (let ((h-radius (/ radius 2))) 72 | (arc-negative (+ x h-radius) y h-radius 0 PI) 73 | (arc (- x h-radius) y h-radius 0 PI)) 74 | (stroke) 75 | (arc (- x (/ radius 2)) y (/ radius 8) 0 (* 2 PI)) 76 | (close-path) 77 | (fill-path) 78 | (arc (+ x (/ radius 2)) y (/ radius 8) 0 (* 2 PI)) 79 | (close-path) 80 | (fill-path) 81 | radius)) 82 | 83 | ;;angle of vector 84 | (defun line-angle (dx dy) 85 | (cond ((zerop dx) (if (>= dy 0) (* 1/2 PI) (* -1/2 PI))) 86 | ((> dx 0) (atan (/ dy dx))) 87 | (t (+ PI (atan (/ dy dx)))))) 88 | 89 | ;;draw point 90 | (defun draw-pointer (fx fy tx ty tr) 91 | (let* ((dx (- fx tx)) 92 | (dy (- fy ty)) 93 | (len (sqrt (+ (expt dx 2) (expt dy 2)))) 94 | (tpk (/ (* tr 6/5) len)) 95 | (tpx (+ tx (* tpk dx))) 96 | (tpy (+ ty (* tpk dy))) 97 | (tp-angle (line-angle dx dy))) 98 | (new-path) 99 | (move-to fx fy) 100 | (line-to tpx tpy) 101 | (save) 102 | (set-line-width (* 2 (get-line-width))) 103 | (stroke) 104 | (restore) 105 | (arc tx ty (* tr 6/5) (- tp-angle (/ PI 4)) (+ tp-angle (/ PI 4))) 106 | (stroke))) 107 | 108 | ;;reprenting space 109 | (defstruct (cons-extents (:conc-name cons-)) 110 | (left 0) 111 | (right 0) 112 | (height 0)) 113 | 114 | ;;get space of cons 115 | (defun get-cons-extents (obj) 116 | (let ((exts (make-cons-extents))) 117 | (when (consp obj) 118 | (let* ((lc (car obj)) 119 | (rc (cdr obj)) 120 | (le (get-cons-extents lc)) 121 | (re (get-cons-extents rc))) 122 | (when (or lc rc) 123 | (incf (cons-height exts) 1) 124 | (incf (cons-height exts) 125 | (max (cons-height le) 126 | (cons-height re))) 127 | (when lc 128 | (incf (cons-left exts) 1) 129 | (incf (cons-left exts) 130 | (cons-left le)) 131 | (incf (cons-left exts) 132 | (cons-right le)) 133 | (when rc 134 | (incf (cons-right exts) 1) 135 | (incf (cons-right exts) 136 | (cons-right re)) 137 | (incf (cons-right exts) 138 | (cons-left re))))))) 139 | exts)) 140 | 141 | ;;draw cons 142 | (defun draw-cons (x y obj hgap vgap) 143 | (if (atom obj) 144 | (draw-atom x y obj) 145 | (let* ((p-radius (draw-cons-node x y)) 146 | (p-left-x (- x (/ p-radius 2))) 147 | (p-right-x (+ x (/ p-radius 2))) 148 | (left-cell (car obj)) 149 | (right-cell (cdr obj)) 150 | (left-exts (get-cons-extents left-cell)) 151 | (right-exts (get-cons-extents right-cell))) 152 | (when left-cell 153 | (let* ((left-x (- x 154 | (* hgap (+ 1 155 | (cons-right 156 | left-exts))))) 157 | (left-y (+ y vgap)) 158 | (left-radius (draw-cons left-x left-y left-cell hgap vgap))) 159 | (draw-pointer p-left-x y left-x left-y left-radius))) 160 | (when right-cell 161 | (let* ((right-x (+ x (* hgap 162 | (max 1 (cons-left 163 | right-exts))))) 164 | (right-y (+ y vgap)) 165 | (right-radius (draw-cons right-x right-y right-cell hgap vgap))) 166 | (draw-pointer p-right-x y right-x right-y right-radius))) 167 | p-radius))) 168 | 169 | ;;entry function 170 | (defun fvs (obj fname &key 171 | (font-size 20) 172 | (line-width 0.5) 173 | (v-gap 60) 174 | (h-gap 25)) 175 | (let* ((exts (get-cons-extents obj)) 176 | (width (* h-gap (+ 2 (cons-left exts) (cons-right exts)))) 177 | (height (* v-gap (+ 2 (cons-height exts)))) 178 | (x (* h-gap (+ 2 (cons-left exts)))) 179 | (y (* v-gap 1)) 180 | (surface (create-pdf-surface (concatenate 'string fname ".pdf") 181 | width 182 | height)) 183 | (*context* (create-context surface))) 184 | (set-font-size font-size) 185 | (set-line-width line-width) 186 | (set-source-rgb 0.0 0.0 0.0) 187 | (paint) 188 | (set-source-rgb 0.1 0.8 0.2) 189 | (draw-cons x y obj h-gap v-gap) 190 | (surface-write-to-png surface (concatenate 'string fname ".png")) 191 | (destroy surface) 192 | (destroy *context*))) 193 | --------------------------------------------------------------------------------