fork download 
  1. ;; Creating our zipper abstraction
  2. (define (make-zipper l p r)
  3.  "Create a zipper with what's to come left of point,
  4.  what's at point and what's right of the point."
  5.  (list l p r))
  6. (define (zipper-point z)
  7.  "Get the point of the zipper."
  8.  (cadr z))
  9. (define (zipper-left z)
  10.  "Get what's left of the zipper, in the order as if
  11.  the point moved to the left."
  12.  (car z))
  13. (define (zipper-right z)
  14.  "Get what's right of the zipper."
  15.  (caddr z))
  16.  
  17.  
  18. ;; Conversion into our new data type
  19. (define (zipper-from-list l)
  20.  "Create a zipper from a (non empty) list, and
  21.  place the point at the first element."
  22.  (make-zipper '() (car l) (cdr l)))
  23.  
  24.  
  25. ;; Movement on zippers.
  26. ;; (2 1) 3 (4 5)
  27. ;; move-right => (3 2 1) 4 (5)
  28. ;; move-left => (1) 2 (3 4 5)
  29. (define (zipper-move-right z)
  30.  "Return a zipper with the point moved one to the
  31.  right."
  32.  (make-zipper
  33.   (cons (zipper-point z) (zipper-left z))
  34.   (car (zipper-right z))
  35.   (cdr (zipper-right z))))
  36. (define (zipper-move-left z)
  37.  "Return a zipper with the point moved one to the
  38.  left."
  39.  (make-zipper
  40.   (cdr (zipper-left z))
  41.   (car (zipper-left z))
  42.   (cons (zipper-point z) (zipper-right z))))
  43.  
  44.  
  45. ;; A special kind of moving, destructing the value at point.
  46. ;; (2 1) 3 (4 5)
  47. ;; zipper-squash-left => (1) 2 (4 5)
  48. ;; zipper-squash-right => (2 1) 4 (5)
  49. (define (zipper-squash-right z)
  50.  "Squash the value at point and close the gap
  51.  with a value from right."
  52.  (make-zipper
  53.   (zipper-left z)
  54.   (car (zipper-right z))
  55.   (cdr (zipper-right z))))
  56. (define (zipper-squash-left z)
  57.  "Squash the value at point and close the gap
  58.  with a value from left."
  59.  (make-zipper
  60.   (cdr (zipper-left z))
  61.   (car (zipper-left z))
  62.   (zipper-right z)))
  63.  
  64. ;; Testing for the end points of the zipper.
  65. (define (zipper-left-end? z)
  66.  "Check whether the zipper is at the left end."
  67.  (eq? '() (zipper-left z)))
  68. (define (zipper-right-end? z)
  69.  "Check whether the zipper is at the right end."
  70.  (eq? '() (zipper-right z)))
  71.  
  72.  
  73. ;; Pull out a list from the current position of the
  74. ;; point.
  75. (define (pull-list-from-zipper z)
  76.  "Pull out a list from the current point of the
  77.  zipper. The list will have the point as first value, followed
  78.  by the one right to it, then the one left of it, then another
  79.  one from the right and so on."
  80.  (cond
  81.   ((zipper-left-end? z) (cons (zipper-point z) (zipper-right z)))
  82.   ((zipper-right-end? z) (cons (zipper-point z) (zipper-left z)))
  83.   (else
  84.    (let* ((p1 (zipper-point z))
  85.              (z1 (zipper-squash-right z))
  86.              (p2 (zipper-point z1))
  87.              (z2 (zipper-squash-left z1)))
  88.     (cons p1 (cons p2 (pull-list-from-zipper z2)))))))
  89.  
  90.  
  91. ;; Utility function
  92. (define (repeated f n)
  93.  "Return a function that repeatedly applies the
  94.  given function."
  95.  (cond
  96.   ((= 0 n) (lambda (o) o))
  97.   (else (lambda (o) ((repeated f (- n 1)) (f o))))))
  98.  
  99.  
  100. ;; What we wanted to to.
  101. (define (unwind l)
  102.  "Move to the mid and pull a list out of the list."
  103.  (let ((steps (quotient (- (length l) 1) 2)))
  104.   (pull-list-from-zipper
  105.    ((repeated zipper-move-right steps) (zipper-from-list l)))))
  106.  
  107.  
  108. ;; Demos
  109. (display (unwind '(1 2 3 4 5 6)))
  110. (newline)
  111. (display (unwind '(7 8 2 9 5 6)))
  112. (newline)
  113. (newline)
  114.  
  115.  
  116. ;; Other examples
  117. (display ((repeated zipper-move-right 5) (zipper-from-list '(1 2 3 4 5 6 7 8 9))))
  118. (newline)
  119.  
  120. (display (pull-list-from-zipper (zipper-move-right
  121.                 (zipper-move-right (zipper-from-list '(1 2 3 4))))))
  122. (newline)
  123.  
Success #stdin #stdout 0.04s 8744KB
comments (?)
stdin 
Standard input is empty
stdout 
(3 4 2 5 1 6)
(2 9 8 5 7 6)

((5 4 3 2 1) 6 (7 8 9))
(3 4 2 1)
https://ideone.com/lhBkCG
language:
Scheme (guile 2.2.4)
created:
10 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!