fork(1) download
copy 
  1. ;; Display that handles circular lists. (2.01)
  2. ;; @see TX5DMj
  3.  
  4. (use srfi-1)
  5.  
  6. (define (my-display x)
  7.   (define (display-atom x prefix)
  8.     (display prefix)
  9.     (display x))
  10.  
  11.   (define (display-cycle x seen prefix)
  12.     (display prefix)
  13.     (display "#")
  14.     (display (- (list-index (lambda (y) (eq? x y)) seen)))
  15.     (display "#"))
  16.  
  17.   (define (try-display x seen prefix)
  18.     (cond
  19.      ((not (pair? x))
  20.       (display-atom x prefix)
  21.       #t)
  22.      ((memq x seen)
  23.       (display-cycle x seen prefix)
  24.       #t)
  25.      (else
  26.       #f)))
  27.  
  28.   (define (loop-outer x seen)
  29.     (if (not (try-display x seen ""))
  30.         (begin
  31.          (display "(")
  32.          (loop-inner x seen "")
  33.          (display ")"))))
  34.  
  35.   (define (loop-inner x seen separator)
  36.     (if (and (not (null? x))
  37.              (not (try-display x seen " . ")))
  38.         (let ((next-seen (cons x seen)))
  39.           (display separator)
  40.           (loop-outer (car x) next-seen)
  41.           (loop-inner (cdr x) next-seen " "))))
  42.  
  43.   (loop-outer x '()))
  44.  
  45. (define (display-nl first . rest)
  46.   (my-display first)
  47.   (for-each (lambda (x) (my-display ", ") (my-display x)) rest)
  48.   (newline))
  49.  
  50. ;; Show.
  51.  
  52. (define (make-cycle x)
  53.   (set-cdr! (last-pair x) x)
  54.   x)
  55.  
  56. (display-nl (list))
  57. (display-nl (list (list)))
  58. (display-nl (list (list (list))))
  59. (display-nl (cons 1 2))
  60.  
  61. (define x (iota 1))
  62. (define y (iota 2))
  63. (define z (iota 3))
  64.  
  65. (display-nl x y z)
  66. (display-nl (make-cycle x))
  67. (display-nl (make-cycle y))
  68. (display-nl (make-cycle z))
  69.  
  70. (define x (iota 1))
  71. (set-car! x x)
  72. (display-nl x)
  73.  
  74. (define x (iota 2))
  75. (set-car! x x)
  76. (display-nl x)
  77.  
  78. (define x (iota 2))
  79. (set-car! (cdr x) x)
  80. (display-nl x)
  81.  
  82. (define x (iota 2))
  83. (set-car! (cdr x) (cdr x))
  84. (display-nl x)
  85.  
  86. (define x (iota 3))
  87. (set-car! (cddr x) x)
  88. (display-nl x)
  89.  
  90. (define x (iota 3))
  91. (set-car! (cddr x) (cdr x))
  92. (display-nl x)
  93.  
  94. (define x (iota 3))
  95. (define y (iota 3))
  96. (set-cdr! (cddr x) y)
  97. (set-car! (cddr x) x)
  98. (display-nl x)
  99.  
  100. (define x (iota 3))
  101. (define y (iota 3))
  102. (set-cdr! (cddr x) y)
  103. (set-car! (cddr y) x)
  104. (display-nl x)
  105. (display-nl y)
  106.  
  107. ;; Expected output.
  108.  
  109. ;()
  110. ;(())
  111. ;((()))
  112. ;(1 . 2)
  113. ;(0), (0 1), (0 1 2)
  114. ;(0 . #0#)
  115. ;(0 1 . #-1#)
  116. ;(0 1 2 . #-2#)
  117. ;(#0#)
  118. ;(#0# 1)
  119. ;(0 #-1#)
  120. ;(0 #0#)
  121. ;(0 1 #-2#)
  122. ;(0 1 #-1#)
  123. ;(0 1 #-2# 0 1 2)
  124. ;(0 1 2 0 1 #-5#)
  125. ;(0 1 (0 1 2 . #-5#))
Success #stdin #stdout 0.01s 8196KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
()
(())
((()))
(1 . 2)
(0), (0 1), (0 1 2)
(0 . #0#)
(0 1 . #-1#)
(0 1 2 . #-2#)
(#0#)
(#0# 1)
(0 #-1#)
(0 #0#)
(0 1 #-2#)
(0 1 #-1#)
(0 1 #-2# 0 1 2)
(0 1 2 0 1 #-5#)
(0 1 (0 1 2 . #-5#))
https://ideone.com/rqHBDP
language:
Scheme (chicken 4.13)
created:
6 days 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!