a map on two lists, as one right fold

evil-map.scm

;; <ski> turbofail : for fun, express a `map' taking two lists with calls to
;;       `foldr' (one for each list)
;; ...
;; <Fuco> what is "map taking two lists"
;; <Fuco> you mean zipWith?
;; ...
;; <Fuco> because you can't do that as a fold on list                      [23:11]
;; <ijp> Fuco: want a bet?
;; ...
;; <ijp> I think I might be able to do it with one
;; <Fuco> please


;; Like Haskell's zipWith, or Scheme's map, this one stops whenever it
;; reaches the end of the shortest list.
(define (evil-map f l1 l2)
  ((fold-right (lambda (x cont)
                 (lambda (l2)
                   (if (null? l2)
                       '()
                       (let ((h (car l2))
                             (t (cdr l2)))
                         (cons (f x h) (cont t))))))
               (lambda (l2)
                 '())
               l1)
   l2))


;; scheme@(guile-user)> (evil-map + '(1 2 3) '(4 5 6))
;; $8 = (5 7 9)
;; scheme@(guile-user)> (evil-map + '(1 2 3) '(4 5))
;; $9 = (5 7)
;; scheme@(guile-user)> (evil-map + '(1 2) '(4 5 6))
;; $10 = (5 7)
;; scheme@(guile-user)> (evil-map cons '(a b c d) '(e f g h))
;; $11 = ((a . e) (b . f) (c . g) (d . h))


;; <ski> ijp : btw, i don't see one call to `foldr-right' for each of the input
;;       lists
;; <ijp> ski: I said I could do it in one. If I can do it with one, I can do it
;;       with two
;; <ski> yes, i know :)                                                    [23:29]
;; <ski> (though the point (which i didn't elaborate) was to do it with the fold
;;       as the only means of recursing and of decomposing the lists)

(define (evil-map2 f l1 l2)
  "the bullshit method"
  ((fold-right (lambda (x cont)
                 (lambda (l2)
                   (if (null? l2)
                       '()
                       (let ((h (car l2))
                             (t (cdr l2)))
                         (cons (f x h) (cont t))))))
               (lambda (l2)
                 '())
               l1)
   (fold-right cons '() l2)))

(define (evil-map3 f l1 l2)
  "probably what ski was after"
  (define lefty
    (fold-right (lambda (x rest)
                  (lambda (k)
                    (k x rest)))
                (lambda _ '())
                l1))
  (define righty
    (fold-right (lambda (y rest)
                  (lambda (x cont)
                    (cons (f x y)
                          (cont rest))))
                (lambda _ '())
                l2))
  (lefty righty))

;; scheme@(guile-user)> (evil-map3 + '(1 2 3) '(4 5 6))
;; $24 = (5 7 9)
;; scheme@(guile-user)> (evil-map3 + '(1 2 3) '(4 5))
;; $25 = (5 7)
;; scheme@(guile-user)> (evil-map3 + '(1 2) '(4 5 6))
;; $26 = (5 7)
;; scheme@(guile-user)> (evil-map3 cons '(a b c d) '(e f g h))
;; $27 = ((a . e) (b . f) (c . g) (d . h))