--- a/package.lisp Sat Nov 12 12:51:30 2016 +0000
+++ b/package.lisp Sun Nov 20 13:40:53 2016 +0000
@@ -9,9 +9,7 @@
:cl-arrows
:sand.quickutils)
(:export
- :average4)
- (:shadowing-import-from :cl-arrows
- :->))
+ :average4))
(defpackage :sand.primes
(:use
@@ -31,9 +29,22 @@
:iterate
:cl-arrows
:sand.quickutils
+ :sand.utils))
+
+(defpackage :sand.generic-arithmetic
+ (:use
+ :cl
+ :losh
+ :iterate
+ :cl-arrows
+ :sandalphon.compiler-macro
+ :sand.quickutils
:sand.utils)
- (:shadowing-import-from :cl-arrows
- :->))
+ (:shadow
+ :+
+ :-
+ :/
+ :*))
(defpackage :sand.parenscript
(:use
@@ -42,9 +53,7 @@
:sand.quickutils
:cl-arrows
:cl-fad
- :parenscript)
- (:shadowing-import-from :cl-arrows
- :->)
+ :parenscript)
(:shadowing-import-from :losh
:%))
--- a/sand.asd Sat Nov 12 12:51:30 2016 +0000
+++ b/sand.asd Sun Nov 20 13:40:53 2016 +0000
@@ -7,26 +7,30 @@
:license "MIT/X11"
:version "0.0.1"
- :depends-on (#:cl-charms
- #:iterate
- #:cl-arrows
- #:cl-fad
- #:split-sequence
- #:parenscript
- #:sketch
- #:losh
- #:drakma
- #:function-cache
- #:yason
- #:flexi-streams
- #:sanitize
- #:html-entities
- #:plump
- #:clss
- #:cl-algebraic-data-type
- #:rs-colors
- #:cffi
- #+sbcl #:sb-sprof
+ :depends-on (
+
+ #+sbcl :sb-sprof
+ :cffi
+ :cl-algebraic-data-type
+ :cl-arrows
+ :cl-charms
+ :cl-fad
+ :clss
+ :compiler-macro
+ :drakma
+ :flexi-streams
+ :function-cache
+ :html-entities
+ :iterate
+ :losh
+ :parenscript
+ :plump
+ :rs-colors
+ :sanitize
+ :sketch
+ :split-sequence
+ :yason
+
)
:serial t
@@ -43,6 +47,7 @@
(:file "graphviz")
(:file "urn")
(:file "random-numbers")
+ (:file "generic-arithmetic")
(:file "ascii")
(:file "markov")
(:file "dijkstra-maps")
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/generic-arithmetic.lisp Sun Nov 20 13:40:53 2016 +0000
@@ -0,0 +1,174 @@
+(in-package :sand.generic-arithmetic)
+
+;;;; ________ __________ __ __________ _ _________ ____ ______
+;;;; / ____/ / / / ____/ //_/ / _/_ __/ | | / / ____( )/ __ \/ ____/
+;;;; / /_ / / / / / / ,< / / / / | | /| / / __/ |// /_/ / __/
+;;;; / __/ / /_/ / /___/ /| | _/ / / / _ | |/ |/ / /___ / _, _/ /___
+;;;; /_/ \____/\____/_/ |_| /___/ /_/ ( ) |__/|__/_____/ /_/ |_/_____/
+;;;; __________ _____ ________ ____|/__ ____ __ ______
+;;;; / ____/ __ \/ _/ | / / ____/ / ____/ / / / / / / / ____/__ __
+;;;; / / __/ / / // // |/ / / __ / /_ / / / / / / / / / __/ /___/ /_
+;;;; / /_/ / /_/ // // /| / /_/ / / __/ / /_/ / /___/ /___ / /__/_ __/_ __/
+;;;; \____/\____/___/_/ |_/\____/ /_/ \____/_____/_____/ \____//_/ /_/
+;;;;
+
+;;; This is a quick and dirty experiment at adding generic arithmetic operators
+;;; to Common Lisp. To add support for operating on another type you would add
+;;; methods for `unaryOP` and `binaryOP`, e.g.:
+;;;
+;;; (defmethod unary+ ((v vector)) v)
+;;;
+;;; (defmethod binary+ ((n number) (v vector))
+;;; (map 'vector (lambda (el) (+ el n)) v))
+;;;
+;;; (defmethod binary+ ((v vector) (n number))
+;;; (binary+ n v))
+;;;
+;;; Compiler macros are defined so that if the op is called on things that are
+;;; known to be `number`s at compile time it will compile in the vanilla CL op
+;;; instead:
+;;;
+;;; (defun foo (x)
+;;; (+ 5 x))
+;;; (disassemble 'foo)
+;;; ; disassembly for FOO
+;;; ; Size: 38 bytes. Origin: #x100ACC85F8
+;;; ; 5F8: 498B4C2460 MOV RCX, [R12+96] ; thread.binding-stack-pointer
+;;; ; no-arg-parsing entry point
+;;; ; 5FD: 48894DF8 MOV [RBP-8], RCX
+;;; ; 601: BA0A000000 MOV EDX, 10
+;;; ; 606: 488BFE MOV RDI, RSI
+;;; ; 609: 488B0590FFFFFF MOV RAX, [RIP-112] ; #<SB-KERNEL:FDEFN +>
+;;; ; 610: B904000000 MOV ECX, 4
+;;; ; 615: FF7508 PUSH QWORD PTR [RBP+8]
+;;; ; 618: FF6009 JMP QWORD PTR [RAX+9]
+;;; ; 61B: 0F0B10 BREAK 16 ; Invalid argument count trap
+;;;
+;;;
+;;; (defun foo-number (x)
+;;; (declare (type number x))
+;;; (+ 5 x))
+;;; (disassemble 'foo-number)
+;;; ; disassembly for FOO-NUMBER
+;;; ; Size: 39 bytes. Origin: #x100ACC854B
+;;; ; 4B: 498B4C2460 MOV RCX, [R12+96] ; thread.binding-stack-pointer
+;;; ; no-arg-parsing entry point
+;;; ; 50: 48894DF8 MOV [RBP-8], RCX
+;;; ; 54: BF0A000000 MOV EDI, 10
+;;; ; 59: 488BD3 MOV RDX, RBX
+;;; ; 5C: 41BBD0010020 MOV R11D, 536871376 ; GENERIC-+
+;;; ; 62: 41FFD3 CALL R11
+;;; ; 65: 488B5DF0 MOV RBX, [RBP-16]
+;;; ; 69: 488BE5 MOV RSP, RBP
+;;; ; 6C: F8 CLC
+;;; ; 6D: 5D POP RBP
+;;; ; 6E: C3 RET
+;;; ; 6F: 0F0B10 BREAK 16 ; Invalid argument count trap
+;;;
+;;;
+;;; (defun foo-byte (x)
+;;; (declare (type (unsigned-byte 8) x))
+;;; (+ 5 x))
+;;; (disassemble 'foo-byte)
+;;; ; disassembly for FOO-BYTE
+;;; ; Size: 22 bytes. Origin: #x100290CB4B
+;;; ; 4B: 498B4C2460 MOV RCX, [R12+96] ; thread.binding-stack-pointer
+;;; ; no-arg-parsing entry point
+;;; ; 50: 48894DF8 MOV [RBP-8], RCX
+;;; ; 54: 488D530A LEA RDX, [RBX+10]
+;;; ; 58: 488BE5 MOV RSP, RBP
+;;; ; 5B: F8 CLC
+;;; ; 5C: 5D POP RBP
+;;; ; 5D: C3 RET
+;;; ; 5E: 0F0B10 BREAK 16 ; Invalid argument count trap
+
+(defmacro define-generic-operation (name op allow-nullary)
+ (let ((unary (symb 'unary name))
+ (binary (symb 'binary name)))
+ `(progn
+ (defgeneric ,unary (x))
+
+ (defmethod ,unary ((x number))
+ (,op x))
+
+ (defgeneric ,binary (x y))
+
+ (defmethod ,binary ((x number) (y number))
+ (,op x y))
+
+ ,(if allow-nullary
+ `(defun ,name (&rest arguments)
+ (cond
+ ((null arguments) (,op))
+ ((null (cdr arguments)) (,unary (car arguments)))
+ (t (reduce #',binary arguments))))
+ `(defun ,name (argument &rest more)
+ (if (null more)
+ (,unary argument)
+ (reduce #',binary more :initial-value argument))))
+
+ (define-compiler-macro ,name (&whole form &rest arguments &environment env)
+ (if (every (rcurry #'subtypep 'number)
+ (mapcar (rcurry #'form-type env) arguments))
+ `(,',op ,@arguments)
+ form))
+
+ ',name)))
+
+
+(define-generic-operation + cl:+ t)
+(define-generic-operation - cl:- nil)
+(define-generic-operation * cl:* t)
+(define-generic-operation / cl:/ nil)
+
+;;;; Example: Vectors
+;;; Addition
+(defmethod unary+ ((v vector)) v)
+
+(defmethod binary+ ((v1 vector) (v2 vector))
+ (map 'vector #'+ v1 v2))
+
+(defmethod binary+ ((v vector) (n number))
+ (map 'vector (lambda (el) (+ el n)) v))
+
+(defmethod binary+ ((n number) (v vector))
+ (binary+ v n))
+
+
+;;; Multiplication
+(defmethod unary* ((v vector)) v)
+
+(defmethod binary* ((v1 vector) (v2 vector))
+ (map 'vector #'* v1 v2))
+
+(defmethod binary* ((v vector) (n number))
+ (map 'vector (lambda (el) (* el n)) v))
+
+(defmethod binary* ((n number) (v vector))
+ (binary* n v))
+
+;;; Subtraction
+(defmethod unary- ((v vector))
+ (map 'vector #'- v))
+
+(defmethod binary- ((v1 vector) (v2 vector))
+ (map 'vector #'- v1 v2))
+
+(defmethod binary- ((v vector) (n number))
+ (map 'vector (lambda (el) (- el n)) v))
+
+(defmethod binary- ((n number) (v vector))
+ (error "Cannot subtract number by a vector: (- ~S ~S)" n v))
+
+;;; Division
+(defmethod unary/ ((v vector))
+ (map 'vector #'/ v))
+
+(defmethod binary/ ((v1 vector) (v2 vector))
+ (map 'vector #'/ v1 v2))
+
+(defmethod binary/ ((v vector) (n number))
+ (map 'vector (lambda (el) (/ el n)) v))
+
+(defmethod binary/ ((n number) (v vector))
+ (error "Cannot divide number by a vector: (/ ~S ~S)" n v))
--- a/vendor/make-quickutils.lisp Sat Nov 12 12:51:30 2016 +0000
+++ b/vendor/make-quickutils.lisp Sun Nov 20 13:40:53 2016 +0000
@@ -9,8 +9,8 @@
:define-constant
:ensure-gethash
:hash-table-alist
+ :hash-table-keys
:hash-table-plist
- :hash-table-keys
:hash-table-values
:n-grams
:once-only
@@ -18,6 +18,7 @@
:read-file-into-string
:required-argument
:riffle
+ :symb
:tree-collect
:with-gensyms
--- a/vendor/quickutils.lisp Sat Nov 12 12:51:30 2016 +0000
+++ b/vendor/quickutils.lisp Sun Nov 20 13:40:53 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :DEFINE-CONSTANT :ENSURE-GETHASH :HASH-TABLE-ALIST :HASH-TABLE-PLIST :HASH-TABLE-KEYS :HASH-TABLE-VALUES :N-GRAMS :ONCE-ONLY :RCURRY :READ-FILE-INTO-STRING :REQUIRED-ARGUMENT :RIFFLE :TREE-COLLECT :WITH-GENSYMS) :ensure-package T :package "SAND.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :DEFINE-CONSTANT :ENSURE-GETHASH :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-PLIST :HASH-TABLE-VALUES :N-GRAMS :ONCE-ONLY :RCURRY :READ-FILE-INTO-STRING :REQUIRED-ARGUMENT :RIFFLE :SYMB :TREE-COLLECT :WITH-GENSYMS) :ensure-package T :package "SAND.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "SAND.QUICKUTILS")
@@ -16,14 +16,14 @@
(setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
:COMPOSE :CURRY :DEFINE-CONSTANT
:ENSURE-GETHASH :HASH-TABLE-ALIST
- :HASH-TABLE-PLIST :MAPHASH-KEYS
- :HASH-TABLE-KEYS :MAPHASH-VALUES
+ :MAPHASH-KEYS :HASH-TABLE-KEYS
+ :HASH-TABLE-PLIST :MAPHASH-VALUES
:HASH-TABLE-VALUES :TAKE :N-GRAMS
:ONCE-ONLY :RCURRY :WITH-OPEN-FILE*
:WITH-INPUT-FROM-FILE
:READ-FILE-INTO-STRING
- :REQUIRED-ARGUMENT :RIFFLE
- :TREE-COLLECT :STRING-DESIGNATOR
+ :REQUIRED-ARGUMENT :RIFFLE :MKSTR
+ :SYMB :TREE-COLLECT :STRING-DESIGNATOR
:WITH-GENSYMS))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun make-gensym-list (length &optional (x "G"))
@@ -155,16 +155,6 @@
alist))
- (defun hash-table-plist (table)
- "Returns a property list containing the keys and values of hash table
-`table`."
- (let ((plist nil))
- (maphash (lambda (k v)
- (setf plist (list* k v plist)))
- table)
- plist))
-
-
(declaim (inline maphash-keys))
(defun maphash-keys (function table)
"Like `maphash`, but calls `function` with each key in the hash table `table`."
@@ -183,6 +173,16 @@
keys))
+ (defun hash-table-plist (table)
+ "Returns a property list containing the keys and values of hash table
+`table`."
+ (let ((plist nil))
+ (maphash (lambda (k v)
+ (setf plist (list* k v plist)))
+ table)
+ plist))
+
+
(declaim (inline maphash-values))
(defun maphash-values (function table)
"Like `maphash`, but calls `function` with each value in the hash table `table`."
@@ -338,6 +338,23 @@
:collect obj))
+ (defun mkstr (&rest args)
+ "Receives any number of objects (string, symbol, keyword, char, number), extracts all printed representations, and concatenates them all into one string.
+
+Extracted from _On Lisp_, chapter 4."
+ (with-output-to-string (s)
+ (dolist (a args) (princ a s))))
+
+
+ (defun symb (&rest args)
+ "Receives any number of objects, concatenates all into one string with `#'mkstr` and converts them to symbol.
+
+Extracted from _On Lisp_, chapter 4.
+
+See also: `symbolicate`"
+ (values (intern (apply #'mkstr args))))
+
+
(defun tree-collect (predicate tree)
"Returns a list of every node in the `tree` that satisfies the `predicate`. If there are any improper lists in the tree, the `predicate` is also applied to their dotted elements."
(let ((sentinel (gensym)))
@@ -402,8 +419,8 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(compose curry define-constant ensure-gethash hash-table-alist
- hash-table-plist hash-table-keys hash-table-values n-grams
+ hash-table-keys hash-table-plist hash-table-values n-grams
once-only rcurry read-file-into-string required-argument riffle
- tree-collect with-gensyms with-unique-names)))
+ symb tree-collect with-gensyms with-unique-names)))
;;;; END OF quickutils.lisp ;;;;