<commit_before>;; ChatLang DSL for chat authoring rules
;;
;; A partial implementation of the top level translator that produces
;; PSI rules.
(use-modules (opencog)
             (opencog nlp)
             (opencog exec)
             (opencog openpsi)
             (opencog eva-behavior)
             (srfi srfi-1)
             (rnrs io ports)
             (ice-9 popen)
             (ice-9 optargs))

(define (chatlang-prefix STR) (string-append "Chatlang: " STR))
(define chatlang-no-constant (Node (chatlang-prefix "No constant terms")))

;; Shared variables for all terms
(define atomese-variable-template (list (TypedVariable (Variable "$S")
                                                       (Type "SentenceNode"))
                                        (TypedVariable (Variable "$P")
                                                       (Type "ParseNode"))))

;; Shared conditions for all terms
(define atomese-condition-template (list (Parse (Variable "$P")
                                                (Variable "$S"))
                                         (State (Anchor "Currently Processing")
                                                (Variable "$S"))))

(define (process-pattern-term TERM ATOMESE)
  "Process a single term -- calls the term function and appends the new
   variables and conditions to the existing pair.
   The atomese are in the form of: ((A B) C)
   where A is the variable declaration, B is the condition, C is the
   term sequence."
  (define no-var-cond (cons '() '()))
  (define atomese-for-term
    (cond ((equal? 'lemma (car TERM))
           (cons (lemma (cdr TERM))
                 (list (Word (get-lemma (cdr TERM))))))
          ((equal? 'word (car TERM))
           (cons (word (cdr TERM))
                 (list (Word (cdr TERM)))))
          ((equal? 'phrase (car TERM))
           (cons (phrase (cdr TERM))
                 (map Word (string-split (cdr TERM) #\ ))))
          ((equal? 'concept (car TERM))
           (let ((var (choose-var-name)))
                (cons (concept (cdr TERM) var)
                      (list (Glob var)))))
          ((equal? 'choices (car TERM))
           (let ((var (choose-var-name)))
                (cons (choices (cdr TERM) var)
                      (list (Glob var)))))
          ((equal? 'unordered-matching (car TERM))
           (let ((var (choose-var-name)))
                (cons (unordered-matching (cdr TERM) var)
                      (list (Glob var)))))
          ((equal? 'negation (car TERM))
           (cons (negation (cdr TERM))
                 '()))
          ((equal? 'anchor-start (car TERM))
           (cons no-var-cond (list "<")))
          ((equal? 'anchor-end (car TERM))
           (cons no-var-cond (list ">")))
          ; TODO
          (else (cons no-var-cond '()))))
  (define vars (append (caar ATOMESE) (caar atomese-for-term)))
  (define conds (append (cdar ATOMESE) (cdar atomese-for-term)))
  (define seq (append (cdr ATOMESE) (cdr atomese-for-term)))
  (cons (cons vars conds) seq))

(define (term-sequence-check SEQ)
  "Checks terms occur in the desired order. This is done when we're using
   DualLink to find the rules, see 'find-chat-rules' for details."
  (let* ((no-start-anchor? (equal? #f (member "<" SEQ)))
         (no-end-anchor? (equal? #f (member ">" SEQ)))
         (start-with (if no-start-anchor? '() (cdr (member "<" SEQ))))
         (end-with (if no-end-anchor?
                       '()
                       (take-while (lambda (t) (not (equal? ">" t))) SEQ)))
         (new-seq (cond ((and (not (null? start-with)) (not (null? end-with)))
                         (append start-with end-with))
                        ; TODO: Append a zero-to-many-GlobNode at the end
                        ((not (null? start-with))
                         (append start-with
                                 (take-while (lambda (t) (not (equal? "<" t))) SEQ)))
                        ; TODO: Append a zero-to-many-GlobNode at the beginning
                        ((not (null? end-with))
                         (append (cdr (member ">" SEQ)) end-with))
                        ; TODO: Append zero-to-many-GlobNodes
                        (else SEQ))))
  ; DualLink couldn't match patterns with no constant terms in it
  ; Mark the rules with no constant terms so that ot cam be found
  ; easily during the matching process
  (if (equal? (length new-seq)
              (length (filter (lambda (x) (equal? 'GlobNode (cog-type x)))
                              new-seq)))
    (Inheritance (List new-seq) chatlang-no-constant))
  ; Wrap it using a TrueLink
  ; TODO: Maybe there is a more elegant way to represent it in the context?
  (True (List new-seq))))

(define yakking (psi-demand "Yakking" 0.9))

(define*-public (chat-rule PATTERN ACTION #:optional NAME)
  "Top level translation function. Pattern is a quoted list of terms,
   and action is a quoted list of actions or a single action."
  (let* ((template (cons atomese-variable-template atomese-condition-template))
         (proc-terms (fold process-pattern-term
                           (cons template '())
                           PATTERN))
         (var-cond (car proc-terms))
         (term-seq (term-sequence-check (cdr proc-terms))))
    term-seq))

(define (get-lemma WORD)
  "A hacky way to quickly find the lemma of a word using WordNet."
  (let* ((cmd-string (string-append "wn " WORD " | grep \"Information available for .\\+\""))
         (port (open-input-pipe cmd-string))
         (lemma ""))
    (do ((line (get-line port) (get-line port)))
        ((eof-object? line))
      (let ((l (car (last-pair (string-split line #\ )))))
        (if (not (equal? WORD l))
          (set! lemma l))))
    (close-pipe port)
    (if (string-null? lemma) WORD lemma)))

(define (get-members CONCEPT)
  "Get the members of a concept. VariableNodes will be ignored, and
   recursive calls will be made in case there are nested concepts."
  (append-map
    (lambda (g)
      (cond ((eq? 'ConceptNode (cog-type g)) (get-members g))
            ((eq? 'VariableNode (cog-type g)) '())
            (else (list g))))
    (cog-outgoing-set
      (cog-execute! (Get (Reference (Variable "$x") CONCEPT))))))

(define-public (chatlang-concept? GLOB CONCEPT)
  "Check if the value grounded for the GlobNode is actually a member
   of the concept."
  (define grd (assoc-ref globs (cog-name GLOB)))<commit_msg>Create the psi-rule<commit_after>;; ChatLang DSL for chat authoring rules
;;
;; A partial implementation of the top level translator that produces
;; PSI rules.
(use-modules (opencog)
             (opencog nlp)
             (opencog exec)
             (opencog openpsi)
             (opencog eva-behavior)
             (srfi srfi-1)
             (rnrs io ports)
             (ice-9 popen)
             (ice-9 optargs))

(define (chatlang-prefix STR) (string-append "Chatlang: " STR))
(define chatlang-no-constant (Node (chatlang-prefix "No constant terms")))

;; Shared variables for all terms
(define atomese-variable-template (list (TypedVariable (Variable "$S")
                                                       (Type "SentenceNode"))
                                        (TypedVariable (Variable "$P")
                                                       (Type "ParseNode"))))

;; Shared conditions for all terms
(define atomese-condition-template (list (Parse (Variable "$P")
                                                (Variable "$S"))
                                         (State (Anchor "Currently Processing")
                                                (Variable "$S"))))

(define (process-pattern-term TERM ATOMESE)
  "Process a single term -- calls the term function and appends the new
   variables and conditions to the existing pair.
   The atomese are in the form of: ((A B) C)
   where A is the variable declaration, B is the condition, C is the
   term sequence."
  (define no-var-cond (cons '() '()))
  (define atomese-for-term
    (cond ((equal? 'lemma (car TERM))
           (cons (lemma (cdr TERM))
                 (list (Word (get-lemma (cdr TERM))))))
          ((equal? 'word (car TERM))
           (cons (word (cdr TERM))
                 (list (Word (cdr TERM)))))
          ((equal? 'phrase (car TERM))
           (cons (phrase (cdr TERM))
                 (map Word (string-split (cdr TERM) #\ ))))
          ((equal? 'concept (car TERM))
           (let ((var (choose-var-name)))
                (cons (concept (cdr TERM) var)
                      (list (Glob var)))))
          ((equal? 'choices (car TERM))
           (let ((var (choose-var-name)))
                (cons (choices (cdr TERM) var)
                      (list (Glob var)))))
          ((equal? 'unordered-matching (car TERM))
           (let ((var (choose-var-name)))
                (cons (unordered-matching (cdr TERM) var)
                      (list (Glob var)))))
          ((equal? 'negation (car TERM))
           (cons (negation (cdr TERM))
                 '()))
          ((equal? 'anchor-start (car TERM))
           (cons no-var-cond (list "<")))
          ((equal? 'anchor-end (car TERM))
           (cons no-var-cond (list ">")))
          ; TODO
          (else (cons no-var-cond '()))))
  (define vars (append (caar ATOMESE) (caar atomese-for-term)))
  (define conds (append (cdar ATOMESE) (cdar atomese-for-term)))
  (define seq (append (cdr ATOMESE) (cdr atomese-for-term)))
  (cons (cons vars conds) seq))

(define (term-sequence-check SEQ)
  "Checks terms occur in the desired order. This is done when we're using
   DualLink to find the rules, see 'find-chat-rules' for details."
  (let* ((no-start-anchor? (equal? #f (member "<" SEQ)))
         (no-end-anchor? (equal? #f (member ">" SEQ)))
         (start-with (if no-start-anchor? '() (cdr (member "<" SEQ))))
         (end-with (if no-end-anchor?
                       '()
                       (take-while (lambda (t) (not (equal? ">" t))) SEQ)))
         (new-seq (cond ((and (not (null? start-with)) (not (null? end-with)))
                         (append start-with end-with))
                        ; TODO: Append a zero-to-many-GlobNode at the end
                        ((not (null? start-with))
                         (append start-with
                                 (take-while (lambda (t) (not (equal? "<" t))) SEQ)))
                        ; TODO: Append a zero-to-many-GlobNode at the beginning
                        ((not (null? end-with))
                         (append (cdr (member ">" SEQ)) end-with))
                        ; TODO: Append zero-to-many-GlobNodes
                        (else SEQ))))
  ; DualLink couldn't match patterns with no constant terms in it
  ; Mark the rules with no constant terms so that ot cam be found
  ; easily during the matching process
  (if (equal? (length new-seq)
              (length (filter (lambda (x) (equal? 'GlobNode (cog-type x)))
                              new-seq)))
    (Inheritance (List new-seq) chatlang-no-constant))
  ; Wrap it using a TrueLink
  ; TODO: Maybe there is a more elegant way to represent it in the context?
  (True (List new-seq))))

(define-public (say text)
  "Say the text and clear the state"
  ; TODO: Something simplier?
  (And (True (Put (DefinedPredicate "Say") (Node text)))
       (True (Put (State (Anchor "Currently Processing") (Variable "$x"))
                  (Concept "Default State")))))

(define (process-action ACTION)
  "Process a single action -- converting it into atomese."
  (cond ((equal? 'say (car ACTION))
         (say (cdr ACTION)))))

(define yakking (psi-demand "Yakking" 0.9))

(define*-public (chat-rule PATTERN ACTION #:optional NAME)
  "Top level translation function. Pattern is a quoted list of terms,
   and action is a quoted list of actions or a single action."
  (let* ((template (cons atomese-variable-template atomese-condition-template))
         (proc-terms (fold process-pattern-term
                           (cons template '())
                           PATTERN))
         (var-list (caar proc-terms))
         (cond-list (cdar proc-terms))
         (term-seq (term-sequence-check (cdr proc-terms)))
         (action (process-action ACTION)))
    (psi-rule
      (list (Satisfaction (VariableList var-list)
                          (And (append cond-list (list term-seq)))))
      action
      (True)
      (stv .9 .9)
      yakking
      NAME)))

(define (get-lemma WORD)
  "A hacky way to quickly find the lemma of a word using WordNet."
  (let* ((cmd-string (string-append "wn " WORD " | grep \"Information available for .\\+\""))
         (port (open-input-pipe cmd-string))
         (lemma ""))
    (do ((line (get-line port) (get-line port)))
        ((eof-object? line))
      (let ((l (car (last-pair (string-split line #\ )))))
        (if (not (equal? WORD l))
          (set! lemma l))))
    (close-pipe port)
    (if (string-null? lemma) WORD lemma)))

(define (get-members CONCEPT)
  "Get the members of a concept. VariableNodes will be ignored, and
   recursive calls will be made in case there are nested concepts."
  (append-map
    (lambda (g)
      (cond ((eq? 'ConceptNode (cog-type g)) (get-members g))
            ((eq? 'VariableNode (cog-type g)) '())
            (else (list g))))
    (cog-outgoing-set
      (cog-execute! (Get (Reference (Variable "$x") CONCEPT))))))

(define-public (chatlang-concept? GLOB CONCEPT)
  "Check if the value grounded for the GlobNode is actually a member
   of the concept."
  (define grd (assoc-ref globs (cog-name GLOB)))
{'fraction_non_alphanumeric': 0.1358334563708844, 'fraction_numerical': 0.0008858703676362026, 'mean_word_length': 1.87073532528078, 'pattern_counts': {'":': 0, '<': 11, '<?xml version=': 0, '>': 11, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 24, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5918833', 'n_tokens_mistral': 4057, 'n_tokens_neox': 3907, 'n_words': 1337}