[ create a new paste ] login | about

Link: http://codepad.org/JJ0UVuws    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Feb 19:
; anagrams within words

(define (take n xs)
  (let loop ((n n) (xs xs) (ys '()))
    (if (or (zero? n) (null? xs))
        (reverse ys)
        (loop (- n 1) (cdr xs)
              (cons (car xs) ys)))))

(define (split-while pred? xs)
  (let loop ((xs xs) (ys '()))
    (if (or (null? xs) (not (pred? (car xs))))
        (values (reverse ys) xs)
        (loop (cdr xs) (cons (car xs) ys)))))

(define sort #f)
(define merge #f)
(let ()
  (define dosort
    (lambda (pred? ls n)
      (if (= n 1)
          (list (car ls))
          (let ((i (quotient n 2)))
            (domerge pred?
                     (dosort pred? ls i)
                     (dosort pred? (list-tail ls i) (- n i)))))))
  (define domerge
    (lambda (pred? l1 l2)
      (cond
        ((null? l1) l2)
        ((null? l2) l1)
        ((pred? (car l2) (car l1))
         (cons (car l2) (domerge pred? l1 (cdr l2))))
        (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  (set! sort
    (lambda (pred? l)
      (if (null? l) l (dosort pred? l (length l)))))
  (set! merge
    (lambda (pred? l1 l2)
      (domerge pred? l1 l2))))

(define (remove x xs) ; delete first occurrence of x in xs
  (call-with-values
    (lambda () (split-while (lambda (c) (char<? c x)) xs))
    (lambda (front back) (append front (cdr back)))))

(define (insert x xs) ; insert x in order in xs
  (call-with-values
    (lambda () (split-while (lambda (c) (char<? c x)) xs))
    (lambda (front back) (append front (list x) back))))

(define (anagram-in-word needle haystack)
  (let* ((len (string-length needle))
         (stop (string-length haystack))
         (needle (sort char<? (string->list needle)))
         (window (sort char<? (take len (string->list haystack)))))
    (let loop ((lo 0) (hi (- len 1)) (window window))
      (cond ((= hi stop) #f)
            ((equal? needle window) #t)
            (else (loop (+ lo 1) (+ hi 1)
                        (insert (string-ref haystack hi)
                          (remove (string-ref haystack lo)
                            window))))))))

(display (anagram-in-word "cat" "actor")) (newline)
(display (anagram-in-word "car" "actor")) (newline)


Output:
1
2
#t
#f


Create a new paste based on this one


Comments: