Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 96 lines (78 sloc) 3.812 kb
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells p...
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 Cells p...
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 Cells p...
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 rep...
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.