sorting etc

words/command.rkt

@@ -1,6 +1,7 @@
 #lang debug racket
 (require racket/string
-         "main.rkt")
+         "main.rkt"
+         "kernscore.rkt")
 
 (module+ raco
   (define command-name (with-handlers ([exn:fail? (λ (exn) #f)])
@@ -19,6 +20,11 @@
   (define count 20)
   (define hide-plurals #true)
   (define proper-names #false)
+  (define title-case #false)
+  (define uppercase #false)
+  (define sort-style #false)
+  (define omit #false)
+  (define reversed #false)
   (command-line
    #:program "words"
    #:argv (current-command-line-arguments)
@@ -29,6 +35,10 @@
    [("-m" "--mandatory") mandatory-arg
                          "mandatory letters"
                          (set! mandatory mandatory-arg)]
+  [("-o" "--omit") omit-arg
+                         "forbidden letters"
+                         (set! omit omit-arg)]
+   
    [("-c" "--combo") combo-arg
                      "mandatory combo"
                      (set! combo combo-arg)]
@@ -46,14 +56,40 @@
     (set! hide-plurals #false)]
    [("-p" "--proper-names") 
     "show proper names"
-                      (set! proper-names #true)])
+    (set! proper-names #true)]
-  (displayln (string-join (make-words #:letters letters
+   [("--sort") sort-arg
+               "sort order"
+               (set! sort-style sort-arg)]
+   [("-r" "--reverse") 
+               "reverse order"
+               (set! reversed #true)]
+   #:once-any
+   [("-t" "--title-case") 
+    "capitalize first letter"
+    (set! title-case #true)]
+   [("-u" "--uppercase") 
+    "capitalize all letters"
+    (set! uppercase #true)])
+  (define words (make-words #:letters letters
                             #:mandatory mandatory
+                            #:omit omit
                             #:combo combo
                             #:count count
                             #:min min-size
                             #:max max-size
                             #:hide-plurals hide-plurals
-                                      #:proper-names proper-names) "\n")))
+                            #:proper-names proper-names
+                            #:all-caps uppercase
+                            #:initial-caps title-case))
+  (define-values (sort-key sort-cmp)
+    (match sort-style
+      ["kernscore" (values kernscore <)]
+      ["alpha" (values values string<=?)]
+      [_ (values #false #false)]))
+  (define sorted-words (cond
+                         [sort-key
+                          (sort words sort-cmp #:key sort-key #:cache-keys? #true)]
+                         [else words]))
+  (displayln (string-join ((if reversed reverse values) sorted-words) "\n")))
 
 

words/kernscore.rkt

@@ -0,0 +1,75 @@
+#lang debug racket
+(require racket/dict)
+(provide (all-defined-out))
+
+(define letter-scores
+  '((A 4 4)
+    (B 1 3)
+    (C 2 3)
+    (D 1 2)
+    (E 1 3)
+    (F 1 3)
+    (G 2 3)
+    (H 1 1)
+    (I 1 1)
+    (J 3 1)
+    (K 1 3)
+    (L 1 4)
+    (M 1 1)
+    (N 1 1)
+    (O 2 2)
+    (P 1 3)
+    (Q 2 2)
+    (R 1 3)
+    (S 3 3)
+    (T 4 4)
+    (U 1 1)
+    (V 4 4)
+    (W 4 4)
+    (X 3 3)
+    (Y 4 4)
+    (Z 3 3)
+    (a 3 3)
+    (b 1 2)
+    (c 2 3)
+    (d 2 1)
+    (e 2 3)
+    (f 3 3)
+    (g 3 3)
+    (h 1 1)
+    (i 1.5 1.5)
+    (j 3 1)
+    (k 1 3)
+    (l 1.5 1.5)
+    (m 1 1)
+    (n 1 1)
+    (o 2 2)
+    (p 1 2)
+    (q 2 1)
+    (r 1 3)
+    (s 3 3)
+    (t 3 3)
+    (u 1 1)
+    (v 4 4)
+    (w 4 4)
+    (x 3 3)
+    (y 4 4)
+    (z 3 3)))
+
+(define left-score-table
+  (for/hasheqv ([(letter scores) (in-dict letter-scores)])
+    (values (car (string->list (symbol->string letter))) (car scores))))
+
+(define right-score-table
+  (for/hasheqv ([(letter scores) (in-dict letter-scores)])
+    (values (car (string->list (symbol->string letter))) (cadr scores))))
+
+
+(define (kernscore word)
+  (define cs (string->list word))
+  (/ (for/sum ([left-c (in-list cs)]
+               [right-c (in-list (cdr cs))])
+       (* (hash-ref right-score-table left-c)
+          (hash-ref left-score-table right-c)))
+     (length cs)))
+