Exercises please

[Robert L.]

http://www.informatimago.com/develop/lisp/l99/index.html

Where we find:

(---------------------------------------------------------------
P13 (**) Run-length encoding of a list (direct solution).

Example:
* (encode-direct '(a a a a b c c a a d e e e e))
((4 A) B (2 C) (2 A) D (4 E))
"

;; Iterative solution, uses only O(r) space:

(defun encode-modified (list)
(let ((result '())
(count 0)
(last-item nil))
(labels ((collect-result ()
(push (if (= 1 count)
last-item
(list count last-item))
result))
(new-item (item)
(setf count 1
last-item item))
(same-item ()
(incf count))
(return-result ()
(when (plusp count)
(collect-result))
(nreverse result)))
(dolist (item list (return-result))
(cond
((zerop count) (new-item item))
((eql item last-item) (same-item))
(t (collect-result)
(new-item item)))))))
---------------------------------------------------------------)


(define (encode items)
(reverse
(fold-slices
(curry span-comparing equal?)
(lambda xs
(if (null? (cdr xs))
(car xs)
(list (length xs) (car xs))))
cons
'()
items)))

(encode '(a a a a b c c a a d e e e e))

'((4 a) b (2 c) (2 a) d (4 e))

Given:

(define (length-at-least n xs)
(if (< n 1)
#t
(and (pair? xs) (length-at-least (- n 1) (cdr xs)))))

(define (span-comparing compare the-list)
(if (null? the-list)
(values '() '())
(let go ((taken '()) (xs the-list))
(cond ((null? (cdr xs)) (values (reverse (append xs taken)) '()))
((compare (car xs) (cadr xs)) (go (cons (car xs) taken) (cdr xs)))
(else (values (reverse (cons (car xs) taken)) (cdr xs)))))))

(define fold-slices
(case-lambda
[(m n f1 f2 init xs)
(let go ((xs xs) (accum init))
(if (or (null? xs) (not (length-at-least m xs)))
accum
(go (drop xs n) (f2 (apply f1 (take xs m)) accum))))]
[(spanner f1 f2 init xs)
(let go ((xs xs) (accum init))
(if (null? xs)
accum
(call-with-values (lambda () (spanner xs))
(lambda (taken tail)
(go tail (f2 (apply f1 taken) accum))))))]))

[Robert L.]

Post by Robert L.

http://www.informatimago.com/develop/lisp/l99/index.html

(---------------------------------------------------------------
P13 (**) Run-length encoding of a list (direct solution).
* (encode-direct '(a a a a b c c a a d e e e e))
((4 A) B (2 C) (2 A) D (4 E))
"
(defun encode-modified (list)
(let ((result '())
(count 0)
(last-item nil))
(labels ((collect-result ()
(push (if (= 1 count)
last-item
(list count last-item))
result))
(new-item (item)
(setf count 1
last-item item))
(same-item ()
(incf count))
(return-result ()
(when (plusp count)
(collect-result))
(nreverse result)))
(dolist (item list (return-result))
(cond
((zerop count) (new-item item))
((eql item last-item) (same-item))
(t (collect-result)
(new-item item)))))))
---------------------------------------------------------------)

Gauche, Chicken, and Racket

(use srfi-1) ;; span for Gauche and Chicken
or
(require srfi/1) ;; span for Racket
(require srfi/26) ;; cut for Racket

(define (encode items)
(if (null? items)
'()
(let ((x (car items)))
(let-values (((these those) (span (cut equal? x <>) items)))
(cons
(if (null? (cdr these)) x (list (length these) x))
(encode those))))))

(encode '(a a a a b c c a a d e e e e))
===>
((4 a) b (2 c) (2 a) d (4 e))

[Robert L.]

Post by Robert L.

http://www.informatimago.com/develop/lisp/l99/index.html

(---------------------------------------------------------------
P13 (**) Run-length encoding of a list (direct solution).
* (encode-direct '(a a a a b c c a a d e e e e))
((4 A) B (2 C) (2 A) D (4 E))
"
(defun encode-modified (list)
(let ((result '())
(count 0)
(last-item nil))
(labels ((collect-result ()
(push (if (= 1 count)
last-item
(list count last-item))
result))
(new-item (item)
(setf count 1
last-item item))
(same-item ()
(incf count))
(return-result ()
(when (plusp count)
(collect-result))
(nreverse result)))
(dolist (item list (return-result))
(cond
((zerop count) (new-item item))
((eql item last-item) (same-item))
(t (collect-result)
(new-item item)))))))
---------------------------------------------------------------)

Gauche, Chicken, and Racket

(use srfi-1) ;; pair-fold-right for Gauche or Chicken
or
(require srfi/1) ;; pair-fold-right for Racket

(define (monotonic-lists seq pred)
(pair-fold-right
(lambda (xs accum)
(if (null? (cdr xs))
(list xs)
(let-values (((a b) (car+cdr accum)))
(if (apply pred (take xs 2))
(alist-cons (car xs) a b)
(cons* (take xs 1) a b)))))
'()
seq))

(define (encode seq)
(map
(lambda (xs)
(let ((len (length xs)) (x (car xs)))
(if (= 1 len) x (list len x))))
(monotonic-lists seq equal?)))

(encode '(a a a a b c c a a d e e e e))
===>
((4 a) b (2 c) (2 a) d (4 e))