Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: mergekenny
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 87 lines (72 sloc) 3.42 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
#|

Cells -- Automatic Dataflow Managememnt

(See defpackage.lisp for license and copyright notigification)

|#

(in-package :cells)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (export '(family-values family-values-sorted
            sort-index sort-direction sort-predicate sort-key
            ^sort-index ^sort-direction ^sort-predicate ^sort-key)))

(defmodel family-values (family)
  (
   (kv-collector :initarg :kv-collector
     :initform #'identity
     :reader kv-collector)

   (kid-values :initform (c? (when (kv-collector self)
                               (funcall (kv-collector self) (^value))))
     :accessor kid-values
     :initarg :kid-values)

   (kv-key :initform #'identity
     :initarg :kv-key
     :reader kv-key)

   (kv-key-test :initform #'equal
     :initarg :kv-key-test
     :reader kv-key-test)

   (kid-factory :initform #'identity
     :initarg :kid-factory
     :reader kid-factory)

   (.kids :initform (c? (c-assert (listp (kid-values self)))
                      (let ((new-kids (mapcan (lambda (kid-value)
                                                (list (or (find kid-value .cache
                                                            :key (kv-key self)
                                                            :test (kv-key-test self))
                                                        (trc nil "family-values forced to make new kid"
                                                          self .cache kid-value)
                                                        (funcall (kid-factory self) self kid-value))))
                                        (^kid-values))))
                        (nconc (mapcan (lambda (old-kid)
                                         (unless (find old-kid new-kids)
                                           (when (fv-kid-keep self old-kid)
                                             (list old-kid))))
                                 .cache)
                          new-kids)))
     :accessor kids
     :initarg :kids)))

(defmethod fv-kid-keep (family old-kid)
  (declare (ignorable family old-kid))
  nil)

(defmodel family-values-sorted (family-values)
  ((sorted-kids :initarg :sorted-kids :accessor sorted-kids
     :initform nil)
   (sort-map :initform (c-in nil) :initarg :sort-map :accessor sort-map)
   (.kids :initform (c? (c-assert (listp (kid-values self)))
                 (mapsort (^sort-map)
                   (the-kids
                    (mapcar (lambda (kid-value)
                              (trc "making kid" kid-value)
                              (or (find kid-value .cache :key (kv-key self) :test (kv-key-test self))
                                (trc nil "family-values forced to make new kid" self .cache kid-value)
                                (funcall (kid-factory self) self kid-value)))
                      (^kid-values)))))
     :accessor kids
     :initarg :kids)))

(defun mapsort (map data)
  ;;(trc "mapsort map" map)
  (if map
      (stable-sort data #'< :key (lambda (datum) (or (position datum map)
                                                       ;(trc "mapsort datum not in map" datum)
                                                       (1+ (length data)))))
    data))

(defobserver sorted-kids ()
  (setf (sort-map self) new-value)) ;; cellular trick to avoid cyclicity
Something went wrong with that request. Please try again.