[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/dYKX6r0x    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Apr 26:
; pairing students

(define sort #f)
(define merge #f)
(let ()
  (define dosort
    (lambda (pred? ls n)
      (if (= n 1)
          (list (car ls))
          (let ((i (quotient n 2)))
            (domerge pred?
                     (dosort pred? ls i)
                     (dosort pred? (list-tail ls i) (- n i)))))))
  (define domerge
    (lambda (pred? l1 l2)
      (cond
        ((null? l1) l2)
        ((null? l2) l1)
        ((pred? (car l2) (car l1))
         (cons (car l2) (domerge pred? l1 (cdr l2))))
        (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  (set! sort
    (lambda (pred? l)
      (if (null? l) l (dosort pred? l (length l)))))
  (set! merge
    (lambda (pred? l1 l2)
      (domerge pred? l1 l2))))

(define (split n xs)
  (let loop ((n n) (xs xs) (zs '()))
    (if (or (zero? n) (null? xs))
        (values (reverse zs) xs)
        (loop (- n 1) (cdr xs) (cons (car xs) zs)))))

(define (last xs) (car (reverse xs)))

(define (but-last xs) (reverse (cdr (reverse xs))))

(define (rotate xs)
  (call-with-values
    (lambda () (split (/ (length xs) 2) xs))
    (lambda (front back)
      (append (list (car front)) (list (car back))
              (but-last (cdr front))
              (cdr back) (list (last front))))))

(define (make-set xs)
  (call-with-values
    (lambda () (split (/ (length xs) 2) xs))
    (lambda (front back)
      (let loop ((front front) (back back) (xss (list)))
        (if (null? front) (reverse xss)
          (loop (cdr front) (cdr back)
                (cons (sort < (list (car front) (car back))) xss)))))))

(define (pairs xs)
  (let loop ((n (length xs)) (xs xs) (xss (list)))
    (if (= n 1) (reverse xss)
      (loop (- n 1) (cons (car xs) (cdr (rotate xs)))
            (cons (make-set xs) xss)))))

(display (pairs '(1 2 3 4))) (newline)
(display (pairs '(1 2 3 4 5 6))) (newline)
(display (pairs '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16))) (newline)


Output:
1
2
3
(((1 3) (2 4)) ((1 4) (2 3)) ((1 2) (3 4)))
(((1 4) (2 5) (3 6)) ((1 5) (4 6) (2 3)) ((1 6) (3 5) (2 4)) ((1 3) (2 6) (4 5)) ((1 2) (3 4) (5 6)))
(((1 9) (2 10) (3 11) (4 12) (5 13) (6 14) (7 15) (8 16)) ((1 10) (9 11) (2 12) (3 13) (4 14) (5 15) (6 16) (7 8)) ((1 11) (10 12) (9 13) (2 14) (3 15) (4 16) (5 8) (6 7)) ((1 12) (11 13) (10 14) (9 15) (2 16) (3 8) (4 7) (5 6)) ((1 13) (12 14) (11 15) (10 16) (8 9) (2 7) (3 6) (4 5)) ((1 14) (13 15) (12 16) (8 11) (7 10) (6 9) (2 5) (3 4)) ((1 15) (14 16) (8 13) (7 12) (6 11) (5 10) (4 9) (2 3)) ((1 16) (8 15) (7 14) (6 13) (5 12) (4 11) (3 10) (2 9)) ((1 8) (7 16) (6 15) (5 14) (4 13) (3 12) (2 11) (9 10)) ((1 7) (6 8) (5 16) (4 15) (3 14) (2 13) (9 12) (10 11)) ((1 6) (5 7) (4 8) (3 16) (2 15) (9 14) (10 13) (11 12)) ((1 5) (4 6) (3 7) (2 8) (9 16) (10 15) (11 14) (12 13)) ((1 4) (3 5) (2 6) (7 9) (8 10) (11 16) (12 15) (13 14)) ((1 3) (2 4) (5 9) (6 10) (7 11) (8 12) (13 16) (14 15)) ((1 2) (3 9) (4 10) (5 11) (6 12) (7 13) (8 14) (15 16)))


Create a new paste based on this one


Comments: