pax_global_header00006660000000000000000000000064115041275360014516gustar00rootroot0000000000000052 comment=844b077e5ac5ef2127603e692af983e9952ebae9 dynamic-classes-20130128-git/000077500000000000000000000000001150412753600156205ustar00rootroot00000000000000dynamic-classes-20130128-git/.gitignore000066400000000000000000000003031150412753600176040ustar00rootroot00000000000000# really this is private to my build process make/ common-lisp.net .vcs GNUmakefile init-lisp.lisp project-init.lisp log5.tar.gz website/output/ test-results/ lift-local.config *.dribble *.fasl dynamic-classes-20130128-git/COPYING000066400000000000000000000021161150412753600166530ustar00rootroot00000000000000Copyright (c) 2008-2008 Gary Warren King (gwking@metabang.com) Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. dynamic-classes-20130128-git/dev/000077500000000000000000000000001150412753600163765ustar00rootroot00000000000000dynamic-classes-20130128-git/dev/define-class.lisp000066400000000000000000000101671150412753600216310ustar00rootroot00000000000000(in-package #:metabang-dynamic-classes) ;;; some class defining functions (defvar *define-class-form* 'metatilities:defclass* "The name of the form used to define a class. Usually, this will be bound to 'defclass* but when we are using GBBOpen, it will probably be bound to define-class or define-class*.") #+test (setf *define-class-form* 'metatilities:defclass*) (defun simple-define-class (superclasses &optional (name (simple-define-class-name superclasses))) "Define a class on the fly..." (cond ((and (length-1-list-p superclasses) (find-class (first superclasses) nil)) (values (first superclasses))) (t (muffle-redefinition-warnings (eval `(progn (when (find-class ',name nil) (setf (find-class ',name) nil)) (defclass* ,name ,(ensure-list superclasses) nil)))) (values name)))) (defun simple-define-class-name (superclasses &optional (package *package*)) (intern (format nil "~{~a~^-AND-~}" superclasses) package)) (defun define-class (class-name superclasses slots &rest class-options) "Define a class with all the bells and whistles on the fly... See simple-define-class for the simpler version." (muffle-redefinition-warnings (eval `(,*define-class-form* ,(or class-name (setf class-name (simple-define-class-name (ensure-list superclasses)))) ,(ensure-list superclasses) (,@(ensure-list slots)) ,@class-options))) (values class-name)) (defun map-subclasses (class fn &key proper?) "Applies fn to each subclass of class. If proper? is true, then the class itself is not included in the mapping. Proper? defaults to nil." (let ((mapped (make-hash-table :test #'eq))) (labels ((mapped-p (class) (gethash class mapped)) (do-it (class root) (unless (mapped-p class) (setf (gethash class mapped) t) (unless (and proper? root) (funcall fn class)) (mapc (lambda (class) (do-it class nil)) (class-direct-subclasses class))))) (do-it (get-class class) t)))) (defun superclasses (thing &key (proper? t)) "Returns a list of superclasses of thing. Thing can be a class, object or symbol naming a class. The list of classes returned is 'proper'; it does not include the class itself." (let ((result (class-precedence-list (finalize-class-if-necessary (get-class thing))))) (if proper? (rest result) result))) (defun find-existing-subclass (superclass superclasses) "Look through all the sub-classes of superclass and see if any of them descend from every class in superclasses." (let ((results nil)) (map-subclasses superclass (lambda (subclass) (let ((last-position -1)) (when (every (lambda (superclass) (let ((pos (position superclass (superclasses subclass :proper? nil) :key (lambda (x) (class-name x))))) (prog1 (and pos (< last-position pos)) (setf last-position pos)))) superclasses) (push (class-name subclass) results))))) (values (first results)))) (defun find-or-create-class (root classes) "Try to find a class which is a subclass of root and all of the other `classes` as well. If no such class exists, then it will be created and returned." (or (find-existing-subclass root classes) (let ((superclasses (remove-redundant-classes classes))) (define-class (simple-define-class-name (remove-redundant-classes superclasses)) classes nil)))) (defun remove-redundant-classes (classes) (loop for class in classes unless (class-redundant-p class classes) collect class)) (defun class-redundant-p (class classes) (some (lambda (other-class) (and (not (eq class other-class)) (subtypep other-class class))) classes)) dynamic-classes-20130128-git/dev/dynamic-class.lisp000066400000000000000000000114151150412753600220200ustar00rootroot00000000000000(in-package #:metabang-dynamic-classes) (defgeneric include-class-dependencies (class-type dynamic-class class-list &rest parameters) (:documentation "")) (defgeneric existing-subclass (class-type class-list) (:documentation "")) ;;; Support for dynamic classes based on the parameters for instantiation... ;;; ;;; Here is a quick history lesson: we've been doing this for shapes, since ;;; there was a massive amount of potential shape superclasses, and only a ;;; small subset were ever used for any given instance, and this was the ;;; cleanest and cutest approach... (defvar *parameter-dynamic-class-table* nil) (defun type->parameter-table (type) (cdr (assoc type *parameter-dynamic-class-table*))) (defun (setf type->parameter-table) (value type) (let ((it (assoc type *parameter-dynamic-class-table*))) (if it (setf (cdr it) value) (setf *parameter-dynamic-class-table* (append *parameter-dynamic-class-table* (list (cons type value)))))) (values value)) (defun parameter->dynamic-class (table parameter) (cdr (assoc parameter table))) (defun (setf parameter->dynamic-class) (value table parameter) (let ((it (assoc parameter table))) (if it (setf (cdr it) value) (let ((temp (cdr table)) (insert (list (cons parameter value)))) (setf (cdr insert) temp (cdr table) insert)))) (values value)) (defun table¶meter->dynamic-class (class-type parameter) (parameter->dynamic-class (type->parameter-table class-type) parameter)) (defun add-parameter->dynamic-class (class-type parameter &rest super-classes) (let* ((current-table (or (type->parameter-table class-type) (list (cons :remove :remove)))) (have-table? (not (eq (caar current-table) :remove)))) (dolist (super-class (ensure-list super-classes)) (let ((it (parameter->dynamic-class current-table parameter))) (if it (pushnew super-class it) (setf (parameter->dynamic-class current-table parameter) (list super-class))))) (unless have-table? (setf (type->parameter-table class-type) current-table))) (values nil)) (defun add-dynamic-class-for-parameters (class-type dynamic-class &rest parameters) (dolist (parameter (ensure-list parameters)) (add-parameter->dynamic-class class-type parameter dynamic-class))) #+Later (defun remove-parameter->dynamic-class (class-type parameter dynamic-class) (let ((primary-table (containers:item-at *parameter-dynamic-class-table* class-type))) (when (and primary-table (containers:item-at primary-table parameter)) (setf (containers:item-at primary-table parameter) (remove dynamic-class (containers:item-at primary-table parameter)))))) (defun empty-add-parameter->dynamic-class (class-type) (setf (type->parameter-table class-type) nil)) (defun empty-all-add-parameter->dynamic-class () (setf *parameter-dynamic-class-table* nil)) (defun dynamic-class-information () (loop for (type . data) in *parameter-dynamic-class-table* collect (list type (loop for (parameter . class) in data collect (list parameter class))))) (defmethod include-class-dependencies ((class-type (eql nil)) dynamic-class class-list &rest parameters) (declare (ignore dynamic-class class-list parameters))) (defmethod existing-subclass ((class-type (eql nil)) (class-list t)) (values nil)) (defun determine-dynamic-class (class-type dynamic-class &rest parameters) (let ((class-list (loop for parameter in parameters for keyword? = t then (not keyword?) when keyword? nconc (loop for class in (table¶meter->dynamic-class class-type parameter) when (or (not dynamic-class) (and dynamic-class (not (subtypep class dynamic-class)))) collect class)))) (setf class-list (apply #'include-class-dependencies class-type dynamic-class class-list parameters)) (when (and dynamic-class (not (some (lambda (class-name) (subtypep dynamic-class class-name)) class-list))) (setf class-list (nconc (list dynamic-class) class-list))) (setf class-list (delete-duplicates class-list)) (let ((it nil)) (cond ((setf it (existing-subclass class-type class-list)) it) (t (if (and (length-1-list-p class-list) (find-class (first class-list) nil)) (first class-list) (define-class nil class-list nil))))))) dynamic-classes-20130128-git/dev/package.lisp000066400000000000000000000013241150412753600206620ustar00rootroot00000000000000(in-package #:common-lisp-user) (defpackage #:metabang-dynamic-classes (:nicknames #:dynamic-classes) (:use #:common-lisp) (:import-from #:metatilities #:ensure-list #:length-1-list-p #:class-precedence-list #:class-direct-subclasses #:get-class #:finalize-class-if-necessary #:muffle-redefinition-warnings) (:export #:existing-subclass #:include-class-dependencies #:add-parameter->dynamic-class #:determine-dynamic-class ;;?? #+(or) #:add-dynamic-class-for-parameters #:remove-parameter->dynamic-class #:empty-add-parameter->dynamic-class #:empty-all-add-parameter->dynamic-class #:parameter->dynamic-class #:find-existing-subclass #:find-or-create-class)) dynamic-classes-20130128-git/dynamic-classes-test.asd000066400000000000000000000014121150412753600223430ustar00rootroot00000000000000(defpackage #:dynamic-classes-test-system (:use #:asdf #:cl)) (in-package #:dynamic-classes-test-system) (defsystem dynamic-classes-test :author "Gary Warren King " :maintainer "Gary Warren King " :licence "MIT Style License; see file COPYING for details" :description "Tests for LIsp Framework for Testing" :components ((:module "setup" :pathname "test/" :components ((:file "packages") (:file "tests" :depends-on ("packages")))) (:module "test" :pathname "test/" :depends-on ("setup") :components ())) :depends-on (:lift :dynamic-classes)) (defmethod operation-done-p ((o test-op) (c (eql (find-system 'dynamic-classes-test)))) (values nil)) dynamic-classes-20130128-git/dynamic-classes.asd000066400000000000000000000013671150412753600213770ustar00rootroot00000000000000(defpackage #:dynamic-classes-system (:use #:common-lisp #:asdf)) (in-package #:dynamic-classes-system) (defsystem dynamic-classes :author "Gary Warren King " :version "1.0.2" :maintainer "Gary Warren King " :licence "MIT Style license" :components ((:module "dev" :serial t :components ((:file "package") (:file "define-class") (:file "dynamic-class")))) :in-order-to ((test-op (load-op dynamic-classes-test))) :perform (test-op :after (op c) (funcall (intern (symbol-name '#:run-tests) :lift) :config :generic)) :depends-on (:metatilities-base)) (defmethod operation-done-p ((o test-op) (c (eql (find-system 'dynamic-classes)))) (values nil)) dynamic-classes-20130128-git/lift-standard.config000066400000000000000000000016411150412753600215450ustar00rootroot00000000000000;;; configuration for LIFT tests ;; settings (:if-dribble-exists :supersede) (:dribble "lift.dribble") (:print-length 10) (:print-level 5) (:print-test-case-names t) ;; suites to run (dynamic-classes-test) ;; report properties (:report-property :title "Dynamic-Classes | Test results") (:report-property :relative-to dynamic-classes-test) (:report-property :style-sheet "test-style.css") (:report-property :if-exists :supersede) (:report-property :format :html) (:report-property :name "test-results/test-report.html") (:report-property :unique-name t) (:build-report) (:report-property :unique-name t) (:report-property :format :describe) (:report-property :name "test-results/test-report.txt") (:build-report) (:report-property :format :save) (:report-property :name "test-results/test-report.sav") (:build-report) (:report-property :format :describe) (:report-property :full-pathname *standard-output*) (:build-report) dynamic-classes-20130128-git/test/000077500000000000000000000000001150412753600165775ustar00rootroot00000000000000dynamic-classes-20130128-git/test/packages.lisp000066400000000000000000000001671150412753600212520ustar00rootroot00000000000000(in-package #:common-lisp-user) (defpackage #:dynamic-classes-test (:use #:common-lisp #:lift #:dynamic-classes)) dynamic-classes-20130128-git/test/tests.lisp000066400000000000000000000001241150412753600206270ustar00rootroot00000000000000(in-package #:dynamic-classes-test) (deftestsuite dynamic-classes-test () ()) dynamic-classes-20130128-git/website/000077500000000000000000000000001150412753600172625ustar00rootroot00000000000000dynamic-classes-20130128-git/website/source/000077500000000000000000000000001150412753600205625ustar00rootroot00000000000000dynamic-classes-20130128-git/website/source/index.md000066400000000000000000000062041150412753600222150ustar00rootroot00000000000000{include resources/header.md}
* [Mailing Lists][3] * [Getting it][4] {remark * [Documentation][5]} * [News][6] {remark * [Test results][tr]} * [Changelog][7] [3]: #mailing-lists [4]: #downloads [5]: documentation/ "documentation link" [6]: #news [7]: changelog.html [tr]: test-report.html
### What it is Class-mixins are a great idea but sometimes they lead to a proliferation of subclasses with names like `printable-touchable-composing-colored-shape-square-mixin` and that's just ugly. Common-Lisp is a dynamic-programming language; Dynamic-Classes brings dynamism to class definition! You define the mixins and associate them with parameters. Then you As an example, here is some code from [cl-containers][] iterators that hooks parameters to iterator mixins: (add-parameter->dynamic-class :iterator :transform 'transforming-iterator-mixin) (add-parameter->dynamic-class :iterator :filter 'filtered-iterator-mixin) (add-parameter->dynamic-class :iterator :unique 'unique-value-iterator-mixin) (add-parameter->dynamic-class :iterator :circular 'circular-iterator-mixin) and here it is in action: > (let ((i (make-iterator '(1 2 3)))) (loop repeat 5 when (move-forward-p i) do (print (next-element i)))) 1 2 3 nil > (let ((i (make-iterator '(1 2 3) :circular t))) (loop repeat 5 when (move-forward-p i) do (print (next-element i)))) 1 2 3 1 2 > (let ((i (make-iterator '(1 2 3) :circular t :transform #'sqrt))) (loop repeat 5 when (move-forward-p i) do (print (next-element i)))) 1.0 1.4142135 1.7320508 1.0 1.4142135 The `make-iterator` function calls `determine-iterator-class` to handle the work of figuring how (and possibly creating) the right class given the parameters. (defmethod make-iterator (iteratee &rest args &key (iterator-class nil) &allow-other-keys) (apply #'make-instance (apply #'determine-iterator-class iteratee iterator-class args) :container iteratee args)) Dynamic-Classes can make prototyping a breeze (and it's lots of fun too)! {anchor mailing-lists} ### Mailing Lists * [dynamic-classes-devel][devel-list]: A list for announcements, questions, patches, bug reports, and so on; It's for everything _but_ the sinking kitchen. {anchor downloads} ### Where is it metabang.com is switching from [darcs][] to [git][] for source control; the current dynamic-classes repository is on [github][github-dynamic-classes] and you can clone it using: git clone git://github.com/gwkkwg/dynamic-classes Dynamic-Classes is also [ASDF installable][]. Its CLiki home is right [where][cliki-home] you'd expect. There's also a handy [gzipped tar file][tarball]. {anchor news} ### What is happening 2010 Dec 21 moved to github. 2008-May-26 We've split off from metatilities and are living large and on our own! More tests and documentation coming ... soon (we hope).
{include resources/footer.md} dynamic-classes-20130128-git/website/source/resources/000077500000000000000000000000001150412753600225745ustar00rootroot00000000000000dynamic-classes-20130128-git/website/source/resources/footer.md000066400000000000000000000026051150412753600244170ustar00rootroot00000000000000 dynamic-classes-20130128-git/website/source/resources/header.md000066400000000000000000000014131150412753600243450ustar00rootroot00000000000000{include shared-links.md} {set-property html yes} {set-property style-sheet "http://common-lisp.net/project/cl-containers/shared/style.css"} {set-property author "Gary Warren King"} {set-property title "Dynamic-Classes | metabang.com"} [devel-list]: http://common-lisp.net/cgi-bin/mailman/listinfo/dynamic-classes-devel [cliki-home]: http://www.cliki.net/dynamic-classes [tarball]: http://common-lisp.net/project/dynamic-classes/dynamic-classes.tar.gz dynamic-classes-20130128-git/website/source/resources/navigation.md000066400000000000000000000000351150412753600252530ustar00rootroot00000000000000 dynamic-classes-20130128-git/website/website.tmproj000066400000000000000000000013531150412753600221630ustar00rootroot00000000000000 documents expanded name source regexFolderFilter !.*/(\.[^/]*|CVS|_darcs|_MTN|\{arch\}|blib|.*~\.nib|.*\.(framework|app|pbproj|pbxproj|xcode(proj)?|bundle))$ sourceDirectory source fileHierarchyDrawerWidth 190 metaData showFileHierarchyDrawer windowFrame {{25, 52}, {543, 700}}