guile-vocabulary-trainer/interact.scm

(library (interact)
  (export interactive-loop
          interact-search
          interact-learn)
  (import (except (rnrs base)
                  vector-for-each)
          (only (guile)
                lambda* λ
                simple-format
                current-output-port
                remainder
                member
                random
                pk)
          ;; GNU Guile batteries
          (ice-9 exceptions)
          (ice-9 match)
          ;; file system
          (fslib)
          ;; json
          (json)
          (json-reader)
          (json-writer)
          ;; custom libraries
          (vocabulary-data)
          (statistics)
          (print-utils)
          ;; custom helper libraries
          (list-procs)
          (alist-procs)
          (math)
          (search)
          (iter-utils)
          (print-utils)
          (bool-utils)
          ;; SRFIs
          (srfi srfi-1)
          ;; SRFI 8 - receive form
          (srfi srfi-8)
          ;; SRFI 43 - vector procs
          (srfi srfi-43)
          (vector-procs)
          ;; SRFI 69 - hash tables
          (srfi srfi-69)
          ;; other libs
          (user-input-output)
          (message-builder)))

;; ===========
;; INTERACTION
;; ===========

(define interact-select-searched-attributes
  (λ (vocabulary)
    "Ask the user which attributes of a vocabulary entry
they want to search in. Return a list of searched in
attributes."
    (let* ([attribute-names (vocabulary-get-attribute-names vocabulary)]
           [additional-choices '("all" "metadata" "translation-data")]
           [all-choices (append additional-choices attribute-names)]
           [num-attributes (length attribute-names)]
           [num-additonal-choices (length additional-choices)]
           [additional-choices-and-values
            `((0 . ,attribute-names)
              (1 . ,(vocabulary-get-metadata-attribute-names vocabulary))
              (2 . ,(vocabulary-get-translation-data-attribute-names vocabulary)))]
           [num-all-choices
            (+ num-attributes
               num-additonal-choices)]
           [attribute-choices
            ;; All choices are returned as a list -- makes later processing
            ;; simpler.
            (map (λ (e1 e2) (cons e1 (list e2)))
                 (range num-additonal-choices num-all-choices)
                 attribute-names)]
           [answer->value-hash-table
            (alist->hash-table
             (append additional-choices-and-values attribute-choices))]
           [message
            (string-append "Which attribute do you want to search?"
                           "\n"
                           (choices->message (range 0 num-all-choices) all-choices))])

      (let ([choice
             (ask-user-for-decision-return-value
              "Which attribute do you want to search?"
              (map number->string (range 0 num-all-choices))
              all-choices
              `(,attribute-names
                ,(vocabulary-get-metadata-attribute-names vocabulary)
                ,(vocabulary-get-translation-data-attribute-names vocabulary)
                ,@attribute-names)
              #:prompt-text "choose")])

        (simple-format (current-output-port) "~a\n" choice)
        (if (pair? choice) choice (cons choice '()))))))


(define interact-choose-number-comparison
  (lambda* (attribute-name)
    "Query the user for a number comparison."

    (define make-compare-as-numbers-otherwise-false
      (λ (compare-func)
        (λ (attr-val raw-input-value)
          (let ([input-value (string->number raw-input-value)])
            (if input-value
                (compare-func attr-val input-value)
                #f)))))

    (define choices-with-texts
      `(("<" . "less than")
        (">" . "greater than")
        ("<=" . "less than or equal")
        (">=" . "greater than or equal")
        ("=" . "equal")
        ("!=" . "not equal")))

    (ask-user-for-decision-return-value
     (simple-format #f
                    "How do you want to compare the searched value with attribute ~a?"
                    attribute-name)
     (map (λ (el) (car el)) choices-with-texts)
     (map (λ (el) (cdr el)) choices-with-texts)
     (list (make-compare-as-numbers-otherwise-false
            (λ (attr-val input-value)
              (< attr-val input-value)))
           (make-compare-as-numbers-otherwise-false
            (λ (attr-val input-value)
              (> attr-val input-value)))
           (make-compare-as-numbers-otherwise-false
            (λ (attr-val input-value)
              (<= attr-val input-value)))
           (make-compare-as-numbers-otherwise-false
            (λ (attr-val input-value)
              (>= attr-val input-value)))
           (make-compare-as-numbers-otherwise-false
            (λ (attr-val input-value)
              (= attr-val input-value)))
           (make-compare-as-numbers-otherwise-false
            (λ (attr-val input-value)
              (not (= attr-val input-value))))))))


(define attribute-lookup
  (λ (vocabulary-entry attribute-name)
    ;; look for the attribute in the metadata
    (alist-refs vocabulary-entry
                (cons "metadata" (list attribute-name))
                ;; if the attribute is not in the
                ;; metadata look for it in the
                ;; translation-data
                #:default-thunk
                (λ ()
                  (alist-refs vocabulary-entry
                              (cons "translation-data" (list attribute-name))
                              #:default-thunk (λ () 'not-found))))))


(define interact-general-comparator
  (λ (vocabulary searched-attributes)
    "Query the user for ways in which attributes shall be
compared to the search term."
    ;; The first entry in the vocabulary is considered to be
    ;; somewhat special, as it is assumed to have the
    ;; structure, which all of the vocabulary entries are
    ;; expected to have and it is used as a guideline for
    ;; operations, which require knowledge about types.
    (let ([voc-entry (get:vocabulary/nth-entry vocabulary 0)])
      ;; TODO: find a good way to specify multiple
      ;; comparators for comparisons, which work with
      ;; the same type (for example numbers) but the
      ;; user wants them to work differently.
      (let next-attribute
          ([remaining-attributes searched-attributes]
           [string-comparator #f]
           [number-comparator #f]
           [boolean-comparator #f]
           [vector-comparator #f])
        (cond
         [(null? remaining-attributes)
          (make-general-comparator #:number-comparator number-comparator
                                   #:string-comparator string-comparator
                                   #:boolean-comparator boolean-comparator
                                   #:vector-comparator vector-comparator)]
         [else
          (cond
           [(and number-comparator
                 string-comparator
                 boolean-comparator
                 vector-comparator)
            (make-general-comparator #:number-comparator number-comparator
                                     #:string-comparator string-comparator
                                     #:boolean-comparator boolean-comparator
                                     #:vector-comparator vector-comparator)]
           [else
            (let* ([attr-name (first remaining-attributes)]
                   [attr-val (attribute-lookup voc-entry attr-name)])
              (cond
               [(number? attr-val)
                (next-attribute (cdr remaining-attributes)
                                string-comparator
                                (interact-choose-number-comparison attr-name)
                                boolean-comparator
                                vector-comparator)]
               [else
                (next-attribute (cdr remaining-attributes)
                                string-comparator
                                number-comparator
                                boolean-comparator
                                vector-comparator)]))])])))))


(define interactive-new-search
  (lambda* (vocabulary #:key (negated #f))
    "Search vocabulary interactively, asking the user what
attributes they would like to search for a search term."
    (let ([metadata (get:vocabulary/metadata vocabulary)]
          [searched-attributes (interact-select-searched-attributes vocabulary)])

      (define attribute-test
        (λ (attr)
          (member (get:attribute/key attr)
                  searched-attributes)))

      (define search-result
        (vocabulary-search vocabulary
                           (ask-user-for-text "" #:prompt-text "search term")
                           #:negated negated
                           #:equal-test?
                           (interact-general-comparator vocabulary searched-attributes)
                           #:attribute-test?
                           (λ (attr)
                             (member (alist-item-key attr)
                                     searched-attributes))))

      (values 'search-result
              `(("metadata" . ,metadata)
                ("words" . ,search-result))))))


(define interact-search
  (lambda* (vocabulary #:key (search-result-vocabulary #f))
    "Search vocabulary interactively."

    (define choices-with-texts
      `(("s" . "new search")
        ("n" . "narrow search results")
        ("!n" . "negated narrow search results")
        ("w" . "widen search results")
        ("!w" . "negated widen search results")
        ("s0" . "reset search results")
        ("i" . "show search result info")
        ("e" . "exit")))

    (let loop ()
      (ask-user-for-decision-with-continuations
       "How do you want to search?"
       (map (λ (el) (car el)) choices-with-texts)
       (map (λ (el) (cdr el)) choices-with-texts)
       (list (λ ()
               (let-values ([(tag data) (interactive-new-search vocabulary)])
                 (interact-search vocabulary
                                  #:search-result-vocabulary
                                  data)))
             (λ ()
               (let-values ([(tag data) (interactive-new-search search-result-vocabulary)])
                 (interact-search vocabulary
                                  #:search-result-vocabulary
                                  data)))
             (λ ()
               (let-values ([(tag data)
                             (interactive-new-search search-result-vocabulary #:negated #t)])
                 (interact-search vocabulary
                                  #:search-result-vocabulary
                                  data)))
             (λ ()
               (let-values ([(tag data) (interactive-new-search vocabulary)])
                 (interact-search vocabulary
                                  #:search-result-vocabulary
                                  (vocabulary-union search-result-vocabulary data))))
             (λ ()
               (let-values ([(tag data) (interactive-new-search vocabulary #:negated #t)])
                 (interact-search vocabulary
                                  #:search-result-vocabulary
                                  (vocabulary-union search-result-vocabulary data))))
             (λ ()
               (interact-search vocabulary))
             (λ ()
               (vector-for-each (λ (ind res)
                                  (display-voc-entry res #:separator "---\n"))
                                (get:vocabulary/entries
                                 (if search-result-vocabulary
                                     search-result-vocabulary
                                     vocabulary)))
               (loop))
             (λ ()
               (print-limited search-result-vocabulary)
               (if search-result-vocabulary
                   (values 'search-result search-result-vocabulary)
                   (values 'vocabulary vocabulary))))))))


(define default-learn-config
  (alist-refs (get-json-from-file (fsing-join "settings.json"))
              '("learn")))

;; TODO: Implement a way to return the whole vocabulary
;; changed to the main interactive loop. One possible way to
;; achieve this is, to only pass a list of indices
;; accompanying the full vocabulary, instead of passing a
;; filtered vocabulary, so that using the indices entries of
;; the full vocabulary can be modified (mutated) and then
;; the full vocabulary can be returned.
(define interact-learn
  (lambda* (vocabulary #:key (config default-learn-config))
    (define question "What do you want to do?")
    (define choices-texts-actions
      `(("n" "next word"
         ,(λ (voc-entries index)
            (learn-loop voc-entries
                        (next-in-circle index (vector-length voc-entries)))))
        ("p" "previous word"
         ,(λ (voc-entries index)
            (learn-loop voc-entries
                        (previous-in-circle index (vector-length voc-entries)))))
        ("sh" "shuffle words"
         ,(λ (voc-entries index)
            (learn-loop (vector-shuffle voc-entries) 0)))
        ("i" "show word info"
         ,(λ (voc-entries index)
            (display-voc-entry (vector-ref voc-entries index)
                               #:meta-attr-visibility-pred
                               (λ (attr-name) #t)
                               #:translation-attr-visibility-pred
                               (λ (attr-name) #t))
            (learn-loop voc-entries (remainder index (vector-length voc-entries)))))
        ("ml" "mark word learned"
         ,(λ (voc-entries index)
            (entries:set-learned-status! voc-entries
                                         (list index)
                                         (list #t))
            (learn-loop voc-entries
                        (next-in-circle index
                                        (vector-length voc-entries)))))
        ("mnl" "mark word not learned"
         ,(λ (voc-entries index)
            (entries:set-learned-status! voc-entries
                                         (list index)
                                         (list #f))
            (learn-loop voc-entries
                        (next-in-circle index
                                        (vector-length voc-entries)))))
        ("cd" "change difficulty"
         ,(λ (voc-entries index)
            (simple-format (current-output-port) "change difficulty - not yet implemented\n")
            (learn-loop voc-entries (remainder index (vector-length voc-entries)))))
        ("cr" "change relevance"
         ,(λ (voc-entries index)
            (simple-format (current-output-port) "change relevance - not yet implemented\n")
            (learn-loop voc-entries (remainder index (vector-length voc-entries)))))
        ("e" "exit learning"
         ,(λ (voc-entries index)
            (values 'search-result vocabulary)))
        ("es" "exit learning saving changes"
         ,(λ (voc-entries index)
            ;; TODO: return filtered or not filtered
            ;; (symbol), depending on how learn was started
            (values 'update
                    `(("metadata" . ,(get:vocabulary/metadata vocabulary))
                      ("words" . ,voc-entries)))))))

    (define meta-attr-visibility-pred
      (λ (attr-name)
        (let ([hidden-attrs
               (alist-refs default-learn-config
                           '("hidden-attributes" "metadata"))])
          (not (vector-contains hidden-attrs attr-name)))))

    (define translation-attr-visibility-pred
      (λ (attr-name)
        (let ([hidden-attrs
               (alist-refs default-learn-config
                           '("hidden-attributes" "translation-data"))])
          (not (vector-contains hidden-attrs attr-name)))))

    (define learn-loop
      (λ (voc-entries index)
        (let ([voc-entry (vector-ref voc-entries index)])
          (display-voc-entry voc-entry
                             #:meta-attr-visibility-pred
                             meta-attr-visibility-pred
                             #:translation-attr-visibility-pred
                             translation-attr-visibility-pred))
        (ask-user-for-decision-with-continuations
         question
         (map (λ (el) (first el)) choices-texts-actions)
         (map (λ (el) (second el)) choices-texts-actions)
         (map (λ (el)
                (λ ()
                  ((third el) voc-entries index)))
              choices-texts-actions))))

    (cond
     [(> (vocabulary/entries:length vocabulary) 0)
      (learn-loop (get:vocabulary/entries vocabulary) 0)]
     [else
      (confirm-info-message "empty vocabulary subset")
      (values 'search-result vocabulary)])))


(define interact-persist
  (λ (vocabulary settings)
    (let ([file-location
           (hash-table-ref/default settings
                                   "vocabulary"
                                   "default-vocabulary.json")])
      (save-vocabulary file-location vocabulary))
    (values 'continue vocabulary)))


(define interact-reload
  (λ (settings)
    (values 'continue
            (read-vocabulary
             (hash-table-ref/default settings
                                     "vocabulary"
                                     "default-vocabulary.json")))))


(define interactive-loop
  (lambda* (vocabulary settings #:key (search-result-vocabulary #f))

    (define choices-texts-actions
      `(("s" "search"
         ,(λ ()
            (interact-search vocabulary
                             #:search-result-vocabulary
                             search-result-vocabulary)))
        ("l" "learn"
         ,(λ () (interact-learn (or search-result-vocabulary vocabulary))))
        ("p" "persist data"
         ,(λ () (interact-persist vocabulary settings)))
        ("r" "reload data"
         ,(λ () (interact-reload settings)))
        ("stat" "show statistics"
         ,(λ ()
            (display-statistics (or search-result-vocabulary vocabulary))
            (cond
             [search-result-vocabulary
              (values 'search-result search-result-vocabulary)]
             [else
              (values 'vocabulary vocabulary)])))
        ("e" "exit"
         ,(λ () (values 'exit 'none)))))

    (define loop
      (lambda* ()
        (let-values ([(tag data)
                      (ask-user-for-decision-with-continuations
                       "What do you want to do?"
                       (map (λ (elem) (first elem)) choices-texts-actions)
                       (map (λ (elem) (second elem)) choices-texts-actions)
                       (map (λ (elem) (third elem)) choices-texts-actions))])
          (cond
           [(eq? tag 'search-result)
            #;(vector-for-each (λ (ind res) (display-voc-entry res #:separator "---\n"))
                             (get:vocabulary/entries data))
            (interactive-loop vocabulary settings #:search-result-vocabulary data)]
           [(eq? tag 'vocabulary)
            (interactive-loop vocabulary settings #:search-result-vocabulary #f)]
           [(eq? tag 'continue)
            (interactive-loop vocabulary settings #:search-result-vocabulary #f)]
           [(eq? tag 'update)
            (simple-format (current-output-port) "~a\n" "updating vocabulary")
            (interactive-loop (vocabulary-merge vocabulary data)
                              settings
                              #:search-result-vocabulary data)]
           [(eq? tag 'exit)
            'exit]
           [else
            (raise-exception
             (make-exception
              (make-non-continuable-error)
              (make-exception-with-message
               "unexpected return value to interactive main loop")
              (make-exception-with-irritants data)
              (make-exception-with-origin 'interactive-loop)))]))))

    ;; start the interaction loop, with unfiltered vocabulary
    (loop)))