fork download
copy 
  1. ;; rplac1 alist 'a 'b -- replace FIRST OCCURENCE of 'a to 'b
  2.  
  3. ;; tests:
  4. ;;  (rplac1 '((((1 2) 3 4) a) 6) 'a 'b)  ==>  ((((1 2) 3 4) b) 6)
  5. ;;  (rplac1 '((((a 2) 3 4) a) 6) 'a 'b)  ==>  ((((b 2) 3 4) a) 6)
  6.  
  7. (define (replace1 xs a b)      ; deriving it step by step...
  8.   (let g ((xs xs))
  9.     (cond
  10.       ((null? xs) xs)        ; http://stackoverflow.com/q/16550176/849891
  11.       ((not (pair? xs))        
  12.         (if (eq? xs a) b xs))
  13.       (else 
  14.         (cons (g (car xs))
  15.               (g (cdr xs)))))))
  16.  
  17. ;; (display (replace1 '((((a 2) 3 4) a) 6) 'a 'b)) (newline)   ;; OK
  18.  
  19. (define (replace2 xs a b)
  20.   (let g ((xs xs) (k (lambda (x) x)))
  21.     (cond
  22.       ((null? xs) (k xs))
  23.       ((not (pair? xs))
  24.         (if (eq? xs a) (k b) (k xs)))
  25.       (else 
  26.         (g (car xs) (lambda (x) 
  27.               (g (cdr xs) (lambda (y) (k (cons x y))))))))))
  28.  
  29. ;; (display (replace2 '((((a 2) 3 4) a) 6) 'a 'b)) (newline)   ;; OK
  30.  
  31. (define (rplac11 xs a b)
  32.   (let g ((xs xs) (f #f) (k (lambda (x y) x)))
  33.     (cond
  34.       ((null? xs) (k xs f))
  35.       ((not (pair? xs))
  36.         (if (eq? xs a) (if (not f) (k b #t) (k a f))
  37.           (k xs f)))
  38.       (else 
  39.         (g (car xs) f (lambda (x f) 
  40.               (g (cdr xs) f (lambda (y f) (k (cons x y) f)))))))))
  41.  
  42. (define (rplac12 xs a b)
  43.   (let g ((xs xs) (f #f) (k (lambda (x y) x)))
  44.     (cond
  45.       ((null? xs) (k xs f))
  46.       ((not (pair? xs))
  47.         (if (eq? xs a) (if (not f) (k b #t) (k a f))
  48.           (k xs f)))
  49.       (f  (k xs f))          ; shortcut!   (Haskelly argnames FTW!)
  50.       (else 
  51.         (g (car xs) f (lambda (x f) 
  52.               (g (cdr xs) f (lambda (y f) (k (cons x y) f)))))))))
  53.  
  54. (define (rplac1 xs a b)
  55.   (let g ((xs xs) (f #f) (k (lambda (x y) x)))
  56.     (cond
  57.       (f          (k xs f))                   ; shortcut right-away!
  58.       ((null? xs) (k xs f))
  59.       ((not (pair? xs))
  60.         (if (eq? xs a) (k b #t) (k xs f)))    ; not f!
  61.       (else 
  62.         (g (car xs)   f   (lambda (x f) 
  63.         (g (cdr xs)   f   (lambda (y f) 
  64.         (if (not f)                           ; keep as much
  65.           (k  xs        f)                    ;  original structure
  66.           (k (cons x y) f))))))))))           ;  as possible
  67.  
  68. (display (rplac1 '((((a 2) 3 4) a) 6) 'a 'b)) (newline)
  69. (display (rplac1 '((((c 2) 3 4) a) 6) 'a 'b)) (newline)
  70. (display (rplac1 '((((c 2) 3 a) a) 6) 'a 'b)) (newline)
  71.  
  72. ;; produces:
  73. ;; Success	 time: 0.03 memory: 4132 signal:0
  74.  
  75. ;; ((((b 2) 3 4) a) 6)
  76. ;; ((((c 2) 3 4) b) 6)
  77. ;; ((((c 2) 3 b) a) 6)
Success #stdin #stdout 0.03s 4132KB
comments ()
stdin
copy 
Standard input is empty
stdout
copy 
((((b 2) 3 4) a) 6)
((((c 2) 3 4) b) 6)
((((c 2) 3 b) a) 6)
https://ideone.com/AbWKxS
rplac1 - CPS - to fix http://stackoverflow.com/a/16550546/849891
language:
Scheme (guile 2.2.4)
created:
11 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!