scsh-make/rule-trans-set.scm

;;; TODO:
;;; 
;;; change to topological sort

;;;
;;; RULE-TRANS-SET
;;;
;;; (make-empty-rule-trans-set) ---> rule-trans-set
;;; 
;;; (make-rule-trans-set rule-candidates known-rules rule-set)
;;; 
;;; (rule-trans-set-rule-candidates rts) ---> (rule-candidate0 ...)
;;; (rule-trans-set-known-rules rts) ---> (known-rule0 ...)
;;; (rule-trans-set-rule-set rts) ---> rule-set
;;;
;;; (rule-trans-set-add! rule-trans-set target prereqs wants-build? build-func)
;;;   ---> rule-trans-set
;;; 
(define-record-type :rule-trans-set
  (make-rule-trans-set rule-candidates known-rules rule-set)
  is-rule-trans-set?
  (rule-candidates rule-trans-set-rule-candidates)
  (known-rules rule-trans-set-known-rules)
  (rule-set rule-trans-set-rule-set))

(define (make-empty-rule-trans-set)
  (let ((rule-candidates '())
	(known-rules (alist-cons '() '() '()))
	(rule-set (make-empty-rule-set)))
    (make-rule-trans-set rule-candidates known-rules rule-set)))

;;; o  every incoming rule is considered as a rule-candidate
;;; o  add the new rule-candidate to rule-candidates
;;; o  run known-rules-update afterwards
(define rule-trans-set-add
  (lambda (rule-trans-set target prereqs wants-build? build-func)
    (known-rules-update 
     (rule-candidate-add rule-trans-set 
			 target 
			 prereqs 
			 wants-build? 
			 build-func))))

(define rule-candidate-add 
  (lambda (rule-trans-set target prereqs wants-build? build-func)
    (let ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
	  (known-rules (rule-trans-set-known-rules rule-trans-set))
	  (rule-set (rule-trans-set-rule-set rule-trans-set))
	  (rule-args (list prereqs wants-build? build-func)))
      (make-rule-trans-set (alist-cons target rule-args rule-candidates)
			   known-rules
			   rule-set))))

(define (rule-candidate-del rule-trans-set target)
  (let ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
	(known-rules (rule-trans-set-known-rules rule-trans-set))
	(rule-set (rule-trans-set-rule-set rule-trans-set)))
    (make-rule-trans-set (alist-delete! target rule-candidates)
			 known-rules
			 rule-set)))

(define (rule-candidate-get rule-trans-set target)
  (let* ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
	 (maybe-rule-candidate (assq target rule-candidates)))
    (if maybe-rule-candidate
	(cons target (cdr (assq target rule-candidates)))
	maybe-rule-candidate)))

;;; o  if a target's prereqs are all in known-rules then the rule-candidate
;;;    can be added to the known-rules as a freshly created rule
;;; o  any rule-candidate with () as prereqs can be added to the known-rules
;;;    as well, so this will be the first element of the known-rules
(define known-rules-add
  (lambda (rule-trans-set target prereqs wants-build? build-func)
    (let ((rule (make-rule (map (lambda (prereq)
				  (known-rules-get rule-trans-set prereq))
				prereqs)
			   wants-build? 
			   build-func))
	  (rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
	  (known-rules (rule-trans-set-known-rules rule-trans-set))
	  (rule-set (rule-trans-set-rule-set rule-trans-set)))
      (make-rule-trans-set rule-candidates 
			   (alist-cons target rule known-rules)
			   (rule-set-add rule rule-set)))))

(define (known-rules-get rule-trans-set target)
  (let* ((known-rules (rule-trans-set-known-rules rule-trans-set))
         (maybe-rule (assoc target known-rules)))
    (if maybe-rule (cdr maybe-rule) maybe-rule)))

(define (known-rules-update rts)
  (let until-no-change ((last-rcs (length (rule-trans-set-rule-candidates rts)))
			(rule-trans-set rts))
    (let* ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
	   (candidate-descs (map cons (map car rule-candidates) 
				      (map cdr rule-candidates))))
      (let for-candidates ((current-candidate-desc (car candidate-descs))
			   (to-do-candidate-desc (cdr candidate-descs))
			   (current-rts rule-trans-set))
	(let ((target (list-ref current-candidate-desc 0))
	      (prereqs (list-ref current-candidate-desc 1))
	      (wants-build? (list-ref current-candidate-desc 2))
	      (build-func (list-ref current-candidate-desc 3)))
	  (let* ((known-rules (rule-trans-set-known-rules current-rts))
		 (new-rts (if (not (memq #f 
					 (map (lambda (prereq) 
						(assoc prereq known-rules))
					      prereqs)))
			      (known-rules-add (rule-candidate-del 
						current-rts 
						target)
					       target prereqs 
					       wants-build? build-func)
			      current-rts)))
	    (if (not (null? to-do-candidate-desc))
		(for-candidates (car to-do-candidate-desc)
				(cdr to-do-candidate-desc)
				new-rts)
		(let ((current-rcs (length (rule-trans-set-rule-candidates 
					    new-rts))))
		  (if (or (= current-rcs last-rcs) (= current-rcs 0))
		      new-rts
		      (until-no-change current-rcs new-rts))))))))))

;;; look for all rule-candidates that can be added to known-rules
;;; and add them to known-rules
;;; (define (known-rules-update rule-trans-set)
;;;   (let ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set)))
;;;     (map (lambda (candidate-desc) 
;;; 	   (apply (lambda (target prereqs wants-build? build-func)
;;; 		    (let ((rules (rule-trans-set-known-rules rule-trans-set)))
;;; 		      (if (not (memq #f (map (lambda (prereq) 
;;; 					       (assq prereq rules))
;;; 					     prereqs)))
;;; 			  (set! rule-trans-set
;;; 				(apply known-rules-add! 
;;; 				       (append (list (rule-candidate-del
;;; 						      rule-trans-set
;;; 						      target))
;;; 					       candidate-desc))))
;;; 			  rule-trans-set))
;;; 		    candidate-desc))
;;; 	 (map cons (map car rule-candidates) (map cdr rule-candidates)))))