fork download
copy 
  1. ; linked list exercises
  2.  
  3. (define (split n xs)
  4.   (let loop ((n n) (xs xs) (zs '()))
  5.     (if (or (zero? n) (null? xs))
  6.         (values (reverse zs) xs)
  7.         (loop (- n 1) (cdr xs) (cons (car xs) zs)))))
  8.  
  9. (define-syntax list-match
  10.   (syntax-rules ()
  11.     ((_ expr (pattern fender ... template) ...)
  12.       (let ((obj expr))
  13.         (cond ((list-match-aux obj pattern fender ...
  14.                 (list template)) => car) ...
  15.               (else (error 'list-match "pattern failure")))))))
  16.  
  17. (define-syntax list-match-aux
  18.   (lambda (stx)
  19.     (define (underscore? x)
  20.       (and (identifier? x) (free-identifier=? x (syntax _))))
  21.     (syntax-case stx (quote quasiquote)
  22.       ((_ obj pattern template)
  23.         (syntax (list-match-aux obj pattern #t template)))
  24.       ((_ obj () fender template)
  25.         (syntax (and (null? obj) fender template)))
  26.       ((_ obj underscore fender template)
  27.         (underscore? (syntax underscore))
  28.         (syntax (and fender template)))
  29.       ((_ obj var fender template)
  30.         (identifier? (syntax var))
  31.         (syntax (let ((var obj)) (and fender template))))
  32.       ((_ obj (quote datum) fender template)
  33.         (syntax (and (equal? obj (quote datum)) fender template)))
  34.       ((_ obj (quasiquote datum) fender template)
  35.         (syntax (and (equal? obj (quasiquote datum)) fender template)))
  36.       ((_ obj (kar . kdr) fender template)
  37.         (syntax (and (pair? obj)
  38.                 (let ((kar-obj (car obj)) (kdr-obj (cdr obj)))
  39.                   (list-match-aux kar-obj kar
  40.                         (list-match-aux kdr-obj kdr fender template))))))
  41.       ((_ obj const fender template)
  42.         (syntax (and (equal? obj const) fender template))))))
  43.  
  44. (define (task1a xs)
  45.   (append (filter even? xs) (filter odd? xs)))
  46.  
  47. (display (task1a '(1 2 3 4 5 6 7 8 9))) (newline)
  48.  
  49. (define (task1b xs)
  50.   (let loop ((xs xs) (evens (list)) (odds (list)))
  51.     (cond ((null? xs) (append (reverse evens) (reverse odds)))
  52.           ((even? (car xs)) (loop (cdr xs) (cons (car xs) evens) odds))
  53.           (else (loop (cdr xs) evens (cons (car xs) odds))))))
  54.  
  55. (display (task1b '(1 2 3 4 5 6 7 8 9))) (newline)
  56.  
  57. (define (task2a xs)
  58.   (let loop ((xs xs) (odds (list)) (evens (list)))
  59.     (cond ((null? xs) (append (reverse odds) (reverse evens)))
  60.           ((null? (cdr xs)) (append (reverse (cons (car xs) odds)) (reverse evens)))
  61.           (else (loop (cddr xs) (cons (car xs) odds) (cons (cadr xs) evens))))))
  62.  
  63. (display (task2a '(1 2 3 4 5 6 7 8 9))) (newline)
  64.  
  65. (define (task2b xs)
  66.   (let loop ((xs xs) (odds (list)) (evens (list)))
  67.     (list-match xs
  68.       (() (append (reverse odds) (reverse evens)))
  69.       ((a) (loop (list) (cons a odds) evens))
  70.       ((a b . xs) (loop xs (cons a odds) (cons b evens))))))
  71.  
  72. (display (task2b '(1 2 3 4 5 6 7 8 9))) (newline)
  73.  
  74. (define (task3 xs)
  75.   (call-with-values
  76.     (lambda () (split (quotient (length xs) 2) (sort xs <)))
  77.     (lambda (los his)
  78.       (let loop ((his his) (los los) (xs (list)))
  79.         (cond ((null? his) xs)
  80.               ((null? los) (cons (car his) xs))
  81.               (else (loop (cdr his) (cdr los) (cons (car los) (cons (car his) xs)))))))))
  82.  
  83. (display (task3 '(1 2 3 4 5 6 7 8 9))) (newline)
  84. (display (task3 '(1 2 3 4 5 6 7 8))) (newline)
Success #stdin #stdout 0.06s 8724KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
(2 4 6 8 1 3 5 7 9)
(2 4 6 8 1 3 5 7 9)
(1 3 5 7 9 2 4 6 8)
(1 3 5 7 9 2 4 6 8)
(9 4 8 3 7 2 6 1 5)
(4 8 3 7 2 6 1 5)
https://ideone.com/j53ajn
language:
Scheme (guile 2.2.4)
created:
5 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!