eee0f45d46b8

Add generic arithmetic experiment
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Sun, 20 Nov 2016 13:40:53 +0000
parents 1b413ff8aa5f
children 864abae279b7
branches/tags (none)
files package.lisp sand.asd src/generic-arithmetic.lisp vendor/make-quickutils.lisp vendor/quickutils.lisp

Changes

--- 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 ;;;;