;; shakespearian insults

;; srfi-13 reference implementations (c) Olin Shivers
;; see http://srfi.schemers.org/srfi-13/srfi-13.scm for licence

;; Library-internal routine
(define (%string-copy! to tstart from fstart fend)
 (if (> fstart tstart)
     (do ((i fstart (+ i 1))
          (j tstart (+ j 1)))
         ((>= i fend))
       (string-set! to j (string-ref from i)))

     (do ((i (- fend 1)                    (- i 1))
          (j (+ -1 tstart (- fend fstart)) (- j 1)))
         ((< i fstart))
       (string-set! to j (string-ref from i)))))

;; string-concatenate
(define (string-concatenate strings)
 (let* ((total (do ((strings strings (cdr strings))
                    (i 0 (+ i (string-length (car strings)))))
                   ((not (pair? strings)) i)))
        (ans (make-string total)))
   (let lp ((i 0) (strings strings))
     (if (pair? strings)
         (let* ((s (car strings))
                (slen (string-length s)))
           (%string-copy! ans i s 0 slen)
           (lp (+ i slen) (cdr strings)))))
   ans))

;; string-join
(define (string-join strings . delim+grammar)
 (let-optionals* delim+grammar ((delim " " (string? delim))
                                (grammar 'infix))
   (let ((buildit (lambda (lis final)
                    (let recur ((lis lis))
                      (if (pair? lis)
                          (cons delim (cons (car lis) (recur (cdr lis))))
                          final)))))

     (cond ((pair? strings)
            (string-concatenate
             (case grammar

               ((infix strict-infix)
                (cons (car strings) (buildit (cdr strings) '())))

               ((prefix) (buildit strings '()))

               ((suffix)
                (cons (car strings) (buildit (cdr strings) (list delim))))

               (else (error "Illegal join grammar"
                            grammar string-join)))))

            ((not (null? strings))
             (error "STRINGS parameter not list." strings string-join))

            ;; STRINGS is ()

            ((eq? grammar 'strict-infix)
             (error "Empty list cannot be joined with STRICT-INFIX grammar."
                    string-join))

            (else "")))))              ; Special-cased for infix grammar.

;; end of srfi-13 stuff

;; stuff

(define shakespeare-first
 '("artless" "bawdy" "beslubbering" "bootless" "churlish" "cockered"
"clouted" "craven" "currish" "dankish" "dissembling" "droning"
"errant" "fawning" "fobbing" "froward" "frothy" "gleeking" "goatish"
"gorbellied" "impertinent" "infectious" "jarring" "loggerheaded"
"lumpish" "mammering" "mangled" "mewling" "paunchy" "pribbling"
"puking" "puny" "qualling" "rank" "reeky" "roguish" "ruttish" "saucy"
"spleeny" "spongy" "surly" "tottering" "unmuzzled" "vain" "venomed"
"villainous" "warped" "wayward" "weedy" "yeasty"))

(define shakespeare-middle
 '("base-court" "bat-fowling" "beef-witted" "beetle-headed"
"boil-brained" "clapper-clawed" "clay-brained" "common-kissing"
"crook-pated" "dismal-dreaming" "dizzy-eyed" "doghearted"
"dread-bolted" "earth-vexing" "elf-skinned" "fat-kidneyed"
"fen-sucked" "flap-mouthed" "fly-bitten" "folly-fallen" "fool-born"
"full-gorged" "guts-griping" "half-faced" "hasty-witted" "hedge-born"
"hell-hated" "idle-headed" "ill-breeding" "ill-nurtured"
"knotty-pated" "milk-livered" "motley-minded" "onion-eyed"
"plume-plucked" "pottle-deep" "pox-marked" "reeling-ripe" "rough-hewn"
"rude-growing" "rump-fed" "shard-borne" "sheep-biting" "spur-galled"
"swag-bellied" "tardy-gaited" "tickle-brained" "toad-spotted"
"unchin-snouted" "weather-bitten"))

(define shakespeare-last
 '("apple-john" "baggage" "barnacle" "bladder" "boar-pig" "bugbear"
"bum-bailey" "canker-blossom" "clack-dish" "clotpole" "coxcomb"
"codpiece" "death-token" "dewberry" "flap-dragon" "flax-wench"
"flirt-gill" "foot-licker" "fustilarian" "giglet" "gudgeon" "haggard"
"harpy" "hedge-pig" "horn-beast" "hugger-mugger" "joithead" "lewdster"
"lout" "maggot-pie" "malt-worm" "mammet" "measle" "minnow" "miscreant"
"moldwarp" "mumble-news" "nut-hook" "pigeon-egg" "pignut" "puttock"
"pumpion" "ratsbane" "scut" "skainsmate" "strumpet" "varlet" "vassal"
"whey-face" "wagtail"))

(define nth list-ref)

;; printing output

(define shakespearian-insult
 (lambda ()
 (string-join
  (map
   (lambda (word-list)
     (nth word-list (random (length word-list))))
   (list shakespeare-first shakespeare-middle shakespeare-last)))))

;; return some html

(define shakespearian-insult-html
       (lambda ()
 `(p
       (i (span (@ (style "font-size: large; font-weight: bold;")) "T")
               "hou " ,(shakespearian-insult) "!"))))

You are viewing proxied material from sdf.org. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.