;; This library is used by match.ss
;; This requires the test data structure.
(module reorder-tests mzscheme
  
  (provide reorder-all-lists)
  
  (require "test-structure.scm")
  
  (require-for-template mzscheme)
  
  ;; There really ought to be a stable sort in the std library.
  
  ;;!(function insertion-sort
  ;;          (form (insertion-sort ls less-than?) -> list)
  ;;          (contract (list (any any -> bool) -> list)))
  ;; This is the classic stable sort.  Any stable sort will do.
  (define insertion-sort 
    (lambda (ls less-than?)
      (define (insert el ls)
        (define (ins ls)
          (cond ((null? ls) (list el))
                ((less-than? el (car ls))
                 (cons el ls))
                (else (cons (car ls) (ins (cdr ls))))))
        (ins ls))
      (letrec ((IS (lambda (ls)
                     (if (null? ls)
                         '()
                         (insert (car ls)
                                 (IS (cdr ls)))))))
        (IS ls))))
  
  ;;!(function make-test-order-func
  ;;          (form (make-test-order-func whole-list) -> less-than?)
  ;;          (contract list -> (any any -> bool)))
  ;; This function creates a test function which has access to the
  ;;whole list of test structures capured in the closure.  This
  ;;function places tests that are used more ahead of those used
  ;;less.  When tests are used an equal number of times the test whos
  ;;membership set has the greatest presence is placed ahead.
  (define make-test-order-func
    (lambda (whole-list)
      (lambda (t1 t2)
        (let ((t1-tu (test-times-used t1))
              (t2-tu (test-times-used t2)))
          (cond ((> t1-tu t2-tu) #t)
                ;; these two new rules allow negate
                ;; tests to be placed properly
                ((and (= t1-tu t2-tu)
                      (shape-test? t1)
                      (not (shape-test? t2))
                      (negate-test? t2))
                 #t)
                ((and (= t1-tu t2-tu)
                      (not (shape-test? t1))
                      (negate-test? t1)
                      (shape-test? t2))
                 #f)
                ((and (= t1-tu t2-tu)
                      (or (equal? (test-used-set t1) (test-used-set t2))
                          (>= (number-of-similar (test-used-set t1) 
                                                 whole-list)
                              (number-of-similar (test-used-set t2) 
                                                 whole-list))))
                 #t)
                (else #f))))))
  
  ;;!(function number-of-similar
  ;;          (form (number-of-similar set ls) -> integer)
  ;;          (contract (list list) -> integer))
  ;; This function returns the number of tests that have a
  ;; membership set similar to set.  A membership set is the set of
  ;; test-lists that have a similar tests as the test itself.
  (define number-of-similar 
    (lambda (set ls)
      (apply + (map (lambda (set2) (if (equal? set set2) 1 0))
                    (map test-used-set ls)))))
  
  ;;!(function reorder-tests
  ;;          (form (reorder-tests2 test-list) -> test-list)
  ;;          (contract list -> list))
  ;; This function reorders one list of test structs.
  (define reorder-tests 
    (lambda (test-list)
      ;;(pretty-print test-list)(newline)
      (insertion-sort test-list (make-test-order-func test-list))))
  
  ;;!(function reorder-all-lists
  ;;          (form (reorder-all-lists2 rendered-list) -> list)
  ;;          (contract list -> list))
  ;; This function reorders all of the rendered-lists that have
  ;; success-functions attached to them.
  (define reorder-all-lists 
    (lambda (rendered-list)
      (if (null? rendered-list)
          '()
          (let ((success-func (cdr (car rendered-list)))
                (rot (reorder-tests (caar rendered-list))))
            ;(pretty-print rot)(newline)
            (cons (cons rot success-func)
                  (reorder-all-lists (cdr rendered-list)))))))
  )