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