fork download
copy 
  1. ; two interview questions
  2.  
  3. (define (range . args)
  4.   (case (length args)
  5.     ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
  6.     ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
  7.     ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
  8.            (let loop ((x(car args)) (xs '()))
  9.              (if (le? (cadr args) x)
  10.                  (reverse xs)
  11.                  (loop (+ x (caddr args)) (cons x xs))))))
  12.     (else (error 'range "unrecognized arguments"))))
  13.  
  14. (define sort #f)
  15. (define merge #f)
  16. (let ()
  17.   (define dosort
  18.     (lambda (pred? ls n)
  19.       (if (= n 1)
  20.           (list (car ls))
  21.           (let ((i (quotient n 2)))
  22.             (domerge pred?
  23.                      (dosort pred? ls i)
  24.                      (dosort pred? (list-tail ls i) (- n i)))))))
  25.   (define domerge
  26.     (lambda (pred? l1 l2)
  27.       (cond
  28.         ((null? l1) l2)
  29.         ((null? l2) l1)
  30.         ((pred? (car l2) (car l1))
  31.          (cons (car l2) (domerge pred? l1 (cdr l2))))
  32.         (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  33.   (set! sort
  34.     (lambda (pred? l)
  35.       (if (null? l) l (dosort pred? l (length l)))))
  36.   (set! merge
  37.     (lambda (pred? l1 l2)
  38.       (domerge pred? l1 l2))))
  39.  
  40. (define (uniq-c eql? xs)
  41.   (if (null? xs) xs
  42.     (let loop ((xs (cdr xs)) (prev (car xs)) (k 1) (result '()))
  43.       (cond ((null? xs) (reverse (cons (cons prev k) result)))
  44.             ((eql? (car xs) prev) (loop (cdr xs) prev (+ k 1) result))
  45.             (else (loop (cdr xs) (car xs) 1 (cons (cons prev k) result)))))))
  46.  
  47. (define rand #f)
  48. (define randint #f)
  49. (let ((two31 #x80000000) (a (make-vector 56 -1)) (fptr #f))
  50.   (define (mod-diff x y) (modulo (- x y) two31)) ; generic version
  51.   ; (define (mod-diff x y) (logand (- x y) #x7FFFFFFF)) ; fast version
  52.   (define (flip-cycle)
  53.     (do ((ii 1 (+ ii 1)) (jj 32 (+ jj 1))) ((< 55 jj))
  54.       (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
  55.     (do ((ii 25 (+ ii 1)) (jj 1 (+ jj 1))) ((< 55 ii))
  56.       (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
  57.     (set! fptr 54) (vector-ref a 55))
  58.   (define (init-rand seed)
  59.     (let* ((seed (mod-diff seed 0)) (prev seed) (next 1))
  60.       (vector-set! a 55 prev)
  61.       (do ((i 21 (modulo (+ i 21) 55))) ((zero? i))
  62.         (vector-set! a i next) (set! next (mod-diff prev next))
  63.         (set! seed (+ (quotient seed 2) (if (odd? seed) #x40000000 0)))
  64.         (set! next (mod-diff next seed)) (set! prev (vector-ref a i)))
  65.       (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle)))
  66.   (define (next-rand)
  67.     (if (negative? (vector-ref a fptr)) (flip-cycle)
  68.       (let ((next (vector-ref a fptr))) (set! fptr (- fptr 1)) next)))
  69.   (define (unif-rand m)
  70.     (let ((t (- two31 (modulo two31 m))))
  71.       (let loop ((r (next-rand)))
  72.         (if (<= t r) (loop (next-rand)) (modulo r m)))))
  73.   (init-rand 19380110) ; happy birthday donald e knuth
  74.   (set! rand (lambda seed
  75.     (cond ((null? seed) (/ (next-rand) two31))
  76.           ((eq? (car seed) 'get) (cons fptr (vector->list a)))
  77.           ((eq? (car seed) 'set) (set! fptr (caadr seed))
  78.                                  (set! a (list->vector (cdadr seed))))
  79.           (else (/ (init-rand (modulo (numerator
  80.                   (inexact->exact (car seed))) two31)) two31)))))
  81.   (set! randint (lambda args
  82.     (cond ((null? (cdr args))
  83.             (if (< (car args) two31) (unif-rand (car args))
  84.               (floor (* (next-rand) (car args)))))
  85.           ((< (car args) (cadr args))
  86.             (let ((span (- (cadr args) (car args))))
  87.               (+ (car args)
  88.                  (if (< span two31) (unif-rand span)
  89.                    (floor (* (next-rand) span))))))
  90.           (else (let ((span (- (car args) (cadr args))))
  91.                   (- (car args)
  92.                      (if (< span two31) (unif-rand span)
  93.                        (floor (* (next-rand) span))))))))))
  94.  
  95. (define (rand2) (randint 2))
  96.  
  97. (define (rand3)
  98.   (let ((x (+ (* 2 (rand2)) (rand2))))
  99.     (if (< x 3) x (rand3))))
  100.  
  101. (display (uniq-c = (sort < (map (lambda (x) (rand3)) (range 1000))))) (newline)
  102.  
  103. (define (make-set chars)
  104.   (define (adjoin x xs)
  105.     (if (member x xs) xs (cons x xs)))
  106.   (do ((chars (string->list chars) (cdr chars))
  107.        (set (list) (adjoin (car chars) set)))
  108.       ((null? chars) (sort char<? set))))
  109. (define (intersect set1 set2)
  110.   (let loop ((set1 set1) (set2 set2) (result (list)))
  111.     (cond ((or (null? set1) (null? set2)) (reverse result))
  112.           ((char<? (car set1) (car set2))
  113.             (loop (cdr set1) set2 result))
  114.           ((char<? (car set2) (car set1))
  115.             (loop set1 (cdr set2) result))
  116.           (else (loop (cdr set1) (cdr set2)
  117.                       (cons (car set1) result))))))
  118. (define (min-set chars words)
  119.   (let ((set (make-set chars)))
  120.     (let loop ((words words) (len 1000) (result (list)))
  121.       (if (null? words) result
  122.         (if (equal? (intersect set (make-set (car words))) set)
  123.             (let ((match-len (string-length (car words))))
  124.               (cond ((< match-len len)
  125.                       (loop (cdr words) match-len (list (car words))))
  126.                     ((< len match-len)
  127.                       (loop (cdr words) len result))
  128.                     (else (loop (cdr words) len (cons (car words) result)))))
  129.             (loop (cdr words) len result))))))
  130.  
  131. (display (min-set "eo" '("hello" "goodbye"))) (newline)
  132. (display (min-set "eo" '("hello" "goodbye" "wrote"))) (newline)
  133. (display (min-set "eo" '("hello" "goodbye" "wrote" "hoe"))) (newline)
Success #stdin #stdout 0.83s 9432KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
((0 . 309) (1 . 351) (2 . 340))
(hello)
(wrote hello)
(hoe)
https://ideone.com/IKwBku
language:
Scheme (guile 2.2.4)
created:
7 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!