フローショップ・スケジューリングのジョンソン・アルゴリズムの実装（Gauche）

johnson.scm

; ジョブを作成する
(define (make-job name len1 len2)
  (list name (cons len1 len2)))

; ジョブの名前を返す
(define (job-name job)
  (car job))

; ジョブの所要時間をペアの形で返す
(define (job-length job)
  (cadr job))

; ジョブの所要時間のうち、短い方を返す
; ペアの car は所要時間
; ペアの cdr は 'first または 'second
(define (job-shorter-length job)
  (let ((len1 (car (job-length job)))
        (len2 (cdr (job-length job))))
    (if (<= len1 len2)
      (cons len1 'first)
      (cons len2 'second))))

; ジョブリストを短い方の所要時間を基準にしてソートする
(define (job-list-sort-by-shorter-length jobs)
  (sort jobs
        <
        (lambda (job)
          (car (job-shorter-length job)))))

; ジョブリストの中から所要時間が最短のものを返す
(define (job-list-shortest jobs)
  (car (job-list-sort-by-shorter-length jobs)))

; 合計所要時間が最短になるように並べ替えたジョブリストを返す
(define (job-list-fastest-order jobs)
  (define (iter rest-jobs acc-jobs1 acc-jobs2)
    (if (null? rest-jobs)
      (append (reverse acc-jobs1)
              acc-jobs2)
      (let ((shortest-job (car rest-jobs))
            (next-jobs (cdr rest-jobs)))
        (let ((which-length
                (cdr (job-shorter-length shortest-job))))
          (cond ((eq? which-length 'first)
                 (iter next-jobs
                       (cons shortest-job acc-jobs1)
                       acc-jobs2))
                ((eq? which-length 'second)
                 (iter next-jobs
                       acc-jobs1
                       (cons shortest-job acc-jobs2)))
                (else (error "job-list-fastest-order: undefined symbol:"
                             which-length)))))))
  (iter (job-list-sort-by-shorter-length jobs) '() '()))

test-johnson.scm

(load "./johnson.scm")

(define j1 (make-job "J1" 5 2))
(define j2 (make-job "J2" 1 6))
(define j3 (make-job "J3" 9 7))
(define j4 (make-job "J4" 3 8))
(define j5 (make-job "J5" 10 3))

(define jobs (list j1 j2 j3 j4 j5))
(define expected (list j2 j4 j3 j5 j1))
(define result (job-list-fastest-order jobs))

(if (equal? result expected)
  (begin
    (print "OK")
    (exit))
  (begin
    (print "Expected:" expected)
    (print "Result:" result)
    (exit 1)))