# HG changeset patch # User Steve Losh # Date 1479649253 0 # Node ID eee0f45d46b832763bda6e3c8c47bfe2c9d05d09 # Parent 1b413ff8aa5f8061eb1b935a5a25fefe8da6f086 Add generic arithmetic experiment diff -r 1b413ff8aa5f -r eee0f45d46b8 package.lisp --- 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 :%)) diff -r 1b413ff8aa5f -r eee0f45d46b8 sand.asd --- 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") diff -r 1b413ff8aa5f -r eee0f45d46b8 src/generic-arithmetic.lisp --- /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] ; # +;;; ; 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)) diff -r 1b413ff8aa5f -r eee0f45d46b8 vendor/make-quickutils.lisp --- 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 diff -r 1b413ff8aa5f -r eee0f45d46b8 vendor/quickutils.lisp --- 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 ;;;;