Skip to content
Newer
Older
100644 96 lines (78 sloc) 3.72 KB
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cell…
ktilton authored
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
8faef55 A slow tedious transition to LLGPL
ktilton authored
2 #|
3
4 Cells -- Automatic Dataflow Managememnt
5
6 Copyright (C) 1995, 2006 by Kenneth Tilton
7
8 This library is free software; you can redistribute it and/or
9 modify it under the terms of the Lisp Lesser GNU Public License
10 (http://opensource.franz.com/preamble.html), known as the LLGPL.
11
12 This library is distributed WITHOUT ANY WARRANTY; without even
13 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
14
15 See the Lisp Lesser GNU Public License for more details.
16
17 |#
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cell…
ktilton authored
18
19 (in-package :cells)
20
21 (eval-when (:compile-toplevel :load-toplevel :execute)
22 (export '(family-values family-values-sorted
23 sort-index sort-direction sort-predicate sort-key
24 ^sort-index ^sort-direction ^sort-predicate ^sort-key)))
25
26 (defmodel family-values (family)
27 (
28 (kv-collector :initarg :kv-collector
29 :initform #'identity
30 :reader kv-collector)
31
32 (kid-values :initform (c? (when (kv-collector self)
5db8960 md-value -> value
ktilton authored
33 (funcall (kv-collector self) (^value))))
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cell…
ktilton authored
34 :accessor kid-values
35 :initarg :kid-values)
36
37 (kv-key :initform #'identity
38 :initarg :kv-key
39 :reader kv-key)
40
41 (kv-key-test :initform #'equal
42 :initarg :kv-key-test
43 :reader kv-key-test)
44
45 (kid-factory :initform #'identity
46 :initarg :kid-factory
47 :reader kid-factory)
48
49 (.kids :initform (c? (c-assert (listp (kid-values self)))
50 (let ((new-kids (mapcan (lambda (kid-value)
51 (list (or (find kid-value .cache
52 :key (kv-key self)
53 :test (kv-key-test self))
54 (trc nil "family-values forced to make new kid"
55 self .cache kid-value)
56 (funcall (kid-factory self) self kid-value))))
57 (^kid-values))))
58 (nconc (mapcan (lambda (old-kid)
59 (unless (find old-kid new-kids)
60 (when (fv-kid-keep self old-kid)
61 (list old-kid))))
62 .cache)
63 new-kids)))
64 :accessor kids
65 :initarg :kids)))
66
67 (defmethod fv-kid-keep (family old-kid)
68 (declare (ignorable family old-kid))
69 nil)
70
71 (defmodel family-values-sorted (family-values)
72 ((sorted-kids :initarg :sorted-kids :accessor sorted-kids
73 :initform nil)
74 (sort-map :initform (c-in nil) :initarg :sort-map :accessor sort-map)
75 (.kids :initform (c? (c-assert (listp (kid-values self)))
76 (mapsort (^sort-map)
77 (the-kids
78 (mapcar (lambda (kid-value)
79 (trc "making kid" kid-value)
80 (or (find kid-value .cache :key (kv-key self) :test (kv-key-test self))
81 (trc nil "family-values forced to make new kid" self .cache kid-value)
82 (funcall (kid-factory self) self kid-value)))
83 (^kid-values)))))
84 :accessor kids
85 :initarg :kids)))
86
87 (defun mapsort (map data)
88 ;;(trc "mapsort map" map)
89 (if map
90 (stable-sort data #'< :key (lambda (datum) (or (position datum map)
91 ;(trc "mapsort datum not in map" datum)
92 (1+ (length data)))))
93 data))
94
a9cec26 Cells 3 Initial release. See also new Celtk module in the same Cells …
ktilton authored
95 (defobserver sorted-kids ()
3e8a1d7 *** empty log message ***
ktilton authored
96 (setf (sort-map self) new-value)) ;; cellular trick to avoid cyclicity
Something went wrong with that request. Please try again.