[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/qH8N4FfU    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Nov 20:
; string subsets

(define (make-hash hash eql? oops size)
  (let ((table (make-vector size '())))
    (lambda (message . args)
      (if (eq? message 'enlist)
          (let loop ((k 0) (result '()))
            (if (= size k)
                result
                (loop (+ k 1) (append (vector-ref table k) result))))
          (let* ((key (car args))
                 (index (modulo (hash key) size))
                 (bucket (vector-ref table index)))
            (case message
              ((lookup fetch get ref recall)
                (let loop ((bucket bucket))
                  (cond ((null? bucket) oops)
                        ((eql? (caar bucket) key) (cdar bucket))
                        (else (loop (cdr bucket))))))
              ((insert insert! ins ins! set set! store store! install install!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket)
                            (list (cons key (cadr args))))
                          ((eql? (caar bucket) key)
                            (cons (cons key (cadr args)) (cdr bucket)))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              ((delete delete! del del! remove remove!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket) '())
                          ((eql? (caar bucket) key)
                            (cdr bucket))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              ((update update!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket)
                            (list (cons key (caddr args))))
                          ((eql? (caar bucket) key)
                            (cons (cons key ((cadr args) key (cdar bucket))) (cdr bucket)))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              (else (error 'hash-table "unrecognized message")) ))))))

(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 (string-find pat str . s)
  (let* ((plen (string-length pat))
         (slen (string-length str))
         (skip (make-vector plen 0)))
    (let loop ((i 1) (j 0))
      (cond ((= i plen))
            ((char=? (string-ref pat i) (string-ref pat j))
              (vector-set! skip i (+ j 1))
              (loop (+ i 1) (+ j 1)))
            ((< 0 j) (loop i (vector-ref skip (- j 1))))
            (else (vector-set! skip i 0)
                  (loop (+ i 1) j))))
    (let loop ((p 0) (s (if (null? s) 0 (car s))))
      (cond ((= s slen) #f)
            ((char=? (string-ref pat p) (string-ref str s))
              (if (= p (- plen 1))
                  (- s plen -1)
                  (loop (+ p 1) (+ s 1))))
            ((< 0 p) (loop (vector-ref skip (- p 1)) s))
            (else (loop p (+ s 1)))))))

(define (subset1? main sub)
  (let ((v (make-vector (string-length main) #f)))
    (define (find c s n)
      (let ((k (string-find c s n)))
        (if (not k) #f
          (if (not (vector-ref v k))
              (begin (vector-set! v k #t) k)
              (find c s (+ k 1))))))
    (let loop ((i 0))
      (cond ((= (string-length sub) i) #t)
            ((find (string (string-ref sub i)) main 0) (loop (+ i 1)))
            (else #f)))))

(define (subset2? main sub)
  (let loop ((m (sort char<? (string->list main)))
             (s (sort char<? (string->list sub))))
    (cond ((null? m) (null? s))
          ((null? s) #t)
          ((char<? (car m) (car s)) (loop (cdr m) s))
          ((char<? (car s) (car m)) #f)
          (else (loop (cdr m) (cdr s))))))

(define (subset3? main sub)
  (let ((h (make-hash char->integer char=? 0 256)))
    (do ((i 0 (+ i 1))) ((= (string-length main) i))
      (let ((c (string-ref main i)))
        (h 'update c (lambda (k v) (+ v 1)) 1)))
    (let loop ((i 0))
      (if (= (string-length sub) i) #t
        (let ((c (string-ref sub i)))
          (if (zero? (h 'lookup c)) #f
            (begin (h 'update c (lambda (k v) (- v 1)) 0)
                   (loop (+ i 1)))))))))

(define (subset4? main sub)
  (let ((v (make-vector 256 0)))
    (do ((i 0 (+ i 1))) ((= (string-length main) i))
      (let ((k (char->integer (string-ref main i))))
        (vector-set! v k (+ (vector-ref v k) 1))))
    (let loop ((i 0))
      (if (= (string-length sub) i) #t
        (let ((k (char->integer (string-ref sub i))))
          (if (zero? (vector-ref v k)) #f
            (begin (vector-set! v k (- (vector-ref v k) 1))
                   (loop (+ i 1)))))))))

(define (prime? n) ; trial division
  (cond ((or (not (integer? n)) (negative? n))
          (error 'prime? "must be non-negative integer"))
        ((< n 2) #f) ((even? n) (= n 2))
        (else (let loop ((d 3))
                (cond ((< n (* d d)) #t)
                      ((zero? (modulo n d)) #f)
                      (else (loop (+ d 2))))))))

(define (nth-prime n) ; counting from 1, not 0
  (if (= n 1) 2
    (let loop ((n (- n 2)) (p 3))
      (cond ((zero? n) p)
            ((prime? (+ p 2))
              (loop (- n 1) (+ p 2)))
            (else (loop n (+ p 2)))))))

(define (subset5? main sub)
  (let loop ((n 1) (m (map add1 (map char->integer (string->list main))))
                   (s (map add1 (map char->integer (string->list sub)))))
    (if (pair? m) (loop (* n (nth-prime (car m))) (cdr m) s)
      (if (null? s) #t
        (let ((d (nth-prime (car s))))
          (if (zero? (modulo n d)) (loop (/ n d) m (cdr s)) #f))))))

(display (subset1? "ABCD" "DA"))
(display (subset1? "ABCD" "DAD"))
(display (subset1? "ABCD" "ABCD"))
(display (subset1? "ABCD" ""))
(newline)

(display (subset2? "ABCD" "DA"))
(display (subset2? "ABCD" "DAD"))
(display (subset2? "ABCD" "ABCD"))
(display (subset2? "ABCD" ""))
(newline)

(display (subset3? "ABCD" "DA"))
(display (subset3? "ABCD" "DAD"))
(display (subset3? "ABCD" "ABCD"))
(display (subset3? "ABCD" ""))
(newline)

(display (subset4? "ABCD" "DA"))
(display (subset4? "ABCD" "DAD"))
(display (subset4? "ABCD" "ABCD"))
(display (subset4? "ABCD" ""))
(newline)

(display (subset5? "ABCD" "DA"))
(display (subset5? "ABCD" "DAD"))
(display (subset5? "ABCD" "ABCD"))
(display (subset5? "ABCD" ""))
(newline)


Output:
1
2
3
4
5
#t#f#t#t
#t#f#t#t
#t#f#t#t
#t#f#t#t
#t#f#t#t


Create a new paste based on this one


Comments: