<commit_before>#lang racket/base

(require "pat-unify.rkt" 
         "error.rkt"
         racket/match
         racket/list
         racket/contract
         racket/set
         (for-syntax racket/base))

(provide (struct-out clause)
         (struct-out prem)
         (struct-out eqn)
         (struct-out dqn)
         search/next
         (struct-out gen-trace))

;; search tracing facility
(provide enable-gen-trace!
         disable-gen-trace!
         last-gen-trace
         get-most-recent-trace
         update-gen-trace!
         generation-logger
         gen-state)

;; clause : head-pat eq/dqs (listof prem)
(define-struct clause (head-pat eq/dqs prems lang name) #:transparent)
;; prem : (-> (listof clauses)) pat
(define-struct prem (mk-clauses pat) #:transparent)
;; eq/dqs : (listof (or/c eq? dq?))
(define-struct eqn (lhs rhs) #:transparent)
;; ps : (listof symbol?) - the universally quantified variables ("parameters")
(define-struct dqn (ps lhs rhs) #:transparent)
(define (prem-clauses prem) ((prem-mk-clauses prem)))

(define-struct partial-rule (pat clauses tr-loc bound) 
  #:transparent)
;; fringe = (listof partial-rule)
;; partial-rule = (partial-rule pat (listof clause) tr-frame)
;; the partial rule is the order we're going to process a given rule in. 
;; If above the bound, we randomize them before putting them into the fringe.

(define-struct fail-cont (env fringe bound)
  #:transparent)

(define-struct gen-trace (tr-loc clause input state bound env) #:prefab)

(define gen-state (make-parameter (set 'shuffle-clauses 'success-jump)))

(define (shuffle-clauses?)
  (set-member? (gen-state) 'shuffle-clauses))

(define (success-jump?)
  (set-member? (gen-state) 'success-jump))


(define bt-count (make-parameter 0))
(define bt-limit (make-parameter 0))
(define (inc-bt-count) 
  (bt-count (add1 (bt-count))))

(define pushdown-count (make-parameter 0))
(define pushdown-limit (make-parameter 0))
(define (inc-pushdown-count)
  (pushdown-count (add1 (pushdown-count))))

(define (search/next clauses input bound lang)
  (define name-nums 0)
  (define fresh-pat (parameterize ([unique-name-nums 0])
                      (begin0
                        (fresh-pat-vars input (make-hash))
                        (set! name-nums (unique-name-nums)))))
  (define fs (list (fail-cont empty-env
                              (list (make-partial-rule fresh-pat 
                                                       (if (shuffle-clauses?)
                                                           (shuffle/favor-recursive-clauses clauses)
                                                           (order-clauses clauses))
                                                       '() bound))
                              bound)))
  (define v-locs (make-hash))
  (λ ()
    (parameterize ([unique-name-nums name-nums]
                   [bt-count 0]
                   [bt-limit (* bound 10)]
                   [pushdown-count 0]
                   [pushdown-limit (* bound 200)])
      (define-values (ans fails)
        (with-handlers ([exn:fail:redex:search-failure? (λ (e) 
                                                          (define f-conts (exn:fail:redex:search-failure-fails e))
                                                          (values (unif-fail) (trim-fails f-conts)))])
          (define-values (env/f fails)
            (fail-back fs))
          (values (and/fail env/f (unify fresh-pat 'any env/f lang))
                  fails)))
      (set-last-gen-trace! (generation-trace))
      (set! fs (if (success-jump?)
                   fails
                   (shuffle-fails fails)))  ;; how to test if we're randomizing here?
      (set! name-nums (unique-name-nums))
      ans)))

(define (trim-fails fs)
  (define rev-fs (reverse fs))
  (reverse
   (let loop ([rfs rev-fs])
     (match rfs
       [(cons (fail-cont _1 _2 (? (λ (b) (< b 0)) bound)) rest)
        (loop rest)]
       [_
        rfs]))))

(define (shuffle-fails fs)
  (cond 
    [((length fs) . > . 0)
     (define-values (ls rs) (split-at fs (random (length fs))))
     (append rs ls)]
    [else fs]))

(define (fail-back fs)
  (inc-bt-count)
  (match fs
    [(list (fail-cont e f b) rest ...)
     (choose-rule e f rest)]
    [_ (values #f fs)]))

(define (choose-rule env fringe fail)
  (cond
    [(empty? fringe)
     (values env fail)]
    [else
     (push-down (car fringe) env (cdr fringe) fail)]))

(define (push-down a-partial-rule env fringe fail)
  (inc-pushdown-count)
  (match-define (partial-rule pat clauses tr-loc bound) a-partial-rule)
  (check-depth-limits bound tr-loc fail)
  (cond
    [(null? clauses)
     (fail-back fail)]
    [else
     (define the-clause (fresh-clause-vars (car clauses)))
     (define res-pe (do-unification the-clause pat env))
     (when (log-receiver? gen-log-recv)
       (log-message (current-logger) 'info (symbol->string (clause-name the-clause))
                    (gen-trace tr-loc the-clause pat (and res-pe #t) bound env)))
     (define failure-fringe
       (cons (struct-copy partial-rule
                          a-partial-rule
                          [clauses (cdr clauses)])
             fringe))
     (cond
       [(not res-pe)
        (choose-rule env failure-fringe fail)]
       [else
        (define new-fringe-elements
          (for/list ([prem (in-list (clause-prems the-clause))]
                     [n (in-naturals)])
            (define prem-cls (prem-clauses prem))
            (make-partial-rule (prem-pat prem) 
                               (if (positive? bound)
                                   (if (shuffle-clauses?)
                                       (shuffle/favor-recursive-clauses clauses)
                                       (order-clauses prem-cls))
                                   (order-clauses prem-cls))
                               (cons n tr-loc)
                               (- bound 1))))
        (define new-fringe (append new-fringe-elements
                                   fringe))
        (choose-rule (p*e-e res-pe)
                     new-fringe
                     (cons (fail-cont env failure-fringe bound) fail))])]))

(define (shuffle/favor-recursive-clauses cs)
  (define candidates (apply append
                            (for/list ([c (in-list cs)])
                              (make-list (add1 (length (clause-prems c))) c))))
  (let loop ([candidates candidates])
    (cond<commit_msg>redex: fix recursive calls to use premises clauses<commit_after>#lang racket/base

(require "pat-unify.rkt" 
         "error.rkt"
         racket/match
         racket/list
         racket/contract
         racket/set
         (for-syntax racket/base))

(provide (struct-out clause)
         (struct-out prem)
         (struct-out eqn)
         (struct-out dqn)
         search/next
         (struct-out gen-trace))

;; search tracing facility
(provide enable-gen-trace!
         disable-gen-trace!
         last-gen-trace
         get-most-recent-trace
         update-gen-trace!
         generation-logger
         gen-state)

;; clause : head-pat eq/dqs (listof prem)
(define-struct clause (head-pat eq/dqs prems lang name) #:transparent)
;; prem : (-> (listof clauses)) pat
(define-struct prem (mk-clauses pat) #:transparent)
;; eq/dqs : (listof (or/c eq? dq?))
(define-struct eqn (lhs rhs) #:transparent)
;; ps : (listof symbol?) - the universally quantified variables ("parameters")
(define-struct dqn (ps lhs rhs) #:transparent)
(define (prem-clauses prem) ((prem-mk-clauses prem)))

(define-struct partial-rule (pat clauses tr-loc bound) 
  #:transparent)
;; fringe = (listof partial-rule)
;; partial-rule = (partial-rule pat (listof clause) tr-frame)
;; the partial rule is the order we're going to process a given rule in. 
;; If above the bound, we randomize them before putting them into the fringe.

(define-struct fail-cont (env fringe bound)
  #:transparent)

(define-struct gen-trace (tr-loc clause input state bound env) #:prefab)

(define gen-state (make-parameter (set 'shuffle-clauses 'success-jump)))

(define (shuffle-clauses?)
  (set-member? (gen-state) 'shuffle-clauses))

(define (success-jump?)
  (set-member? (gen-state) 'success-jump))


(define bt-count (make-parameter 0))
(define bt-limit (make-parameter 0))
(define (inc-bt-count) 
  (bt-count (add1 (bt-count))))

(define pushdown-count (make-parameter 0))
(define pushdown-limit (make-parameter 0))
(define (inc-pushdown-count)
  (pushdown-count (add1 (pushdown-count))))

(define (search/next clauses input bound lang)
  (define name-nums 0)
  (define fresh-pat (parameterize ([unique-name-nums 0])
                      (begin0
                        (fresh-pat-vars input (make-hash))
                        (set! name-nums (unique-name-nums)))))
  (define fs (list (fail-cont empty-env
                              (list (make-partial-rule 
                                     fresh-pat 
                                     (if (shuffle-clauses?)
                                         (shuffle/favor-recursive-clauses clauses)
                                         (order-clauses clauses))
                                     '() bound))
                              bound)))
  (define v-locs (make-hash))
  (λ ()
    (parameterize ([unique-name-nums name-nums]
                   [bt-count 0]
                   [bt-limit (* bound 10)]
                   [pushdown-count 0]
                   [pushdown-limit (* bound 200)])
      (define-values (ans fails)
        (with-handlers ([exn:fail:redex:search-failure? (λ (e) 
                                                          (define f-conts (exn:fail:redex:search-failure-fails e))
                                                          (values (unif-fail) (trim-fails f-conts)))])
          (define-values (env/f fails)
            (fail-back fs))
          (values (and/fail env/f (unify fresh-pat 'any env/f lang))
                  fails)))
      (set-last-gen-trace! (generation-trace))
      (set! fs (if (success-jump?)
                   fails
                   (shuffle-fails fails)))  ;; how to test if we're randomizing here?
      (set! name-nums (unique-name-nums))
      ans)))

(define (trim-fails fs)
  (define rev-fs (reverse fs))
  (reverse
   (let loop ([rfs rev-fs])
     (match rfs
       [(cons (fail-cont _1 _2 (? (λ (b) (< b 0)) bound)) rest)
        (loop rest)]
       [_
        rfs]))))

(define (shuffle-fails fs)
  (cond 
    [((length fs) . > . 0)
     (define-values (ls rs) (split-at fs (random (length fs))))
     (append rs ls)]
    [else fs]))

(define (fail-back fs)
  (inc-bt-count)
  (match fs
    [(list (fail-cont e f b) rest ...)
     (choose-rule e f rest)]
    [_ (values #f fs)]))

(define (choose-rule env fringe fail)
  (cond
    [(empty? fringe)
     (values env fail)]
    [else
     (push-down (car fringe) env (cdr fringe) fail)]))

(define (push-down a-partial-rule env fringe fail)
  (inc-pushdown-count)
  (match-define (partial-rule pat clauses tr-loc bound) a-partial-rule)
  (check-depth-limits bound tr-loc fail)
  (cond
    [(null? clauses)
     (fail-back fail)]
    [else
     (define the-clause (fresh-clause-vars (car clauses)))
     (define res-pe (do-unification the-clause pat env))
     (when (log-receiver? gen-log-recv)
       (log-message (current-logger) 'info (symbol->string (clause-name the-clause))
                    (gen-trace tr-loc the-clause pat (and res-pe #t) bound env)))
     (define failure-fringe
       (cons (struct-copy partial-rule
                          a-partial-rule
                          [clauses (cdr clauses)])
             fringe))
     (cond
       [(not res-pe)
        (choose-rule env failure-fringe fail)]
       [else
        (define new-fringe-elements
          (for/list ([prem (in-list (clause-prems the-clause))]
                     [n (in-naturals)])
            (define prem-cls (prem-clauses prem))
            (make-partial-rule (prem-pat prem) 
                               (if (positive? bound)
                                   (if (shuffle-clauses?)
                                       (shuffle/favor-recursive-clauses prem-cls)
                                       (order-clauses prem-cls))
                                   (order-clauses prem-cls))
                               (cons n tr-loc)
                               (- bound 1))))
        (define new-fringe (append new-fringe-elements
                                   fringe))
        (choose-rule (p*e-e res-pe)
                     new-fringe
                     (cons (fail-cont env failure-fringe bound) fail))])]))

(define (shuffle/favor-recursive-clauses cs)
  (define candidates (apply append
                            (for/list ([c (in-list cs)])
                              (make-list (add1 (length (clause-prems c))) c))))
  (let loop ([candidates candidates])
    (cond
{'fraction_non_alphanumeric': 0.13139931740614336, 'fraction_numerical': 0.0034129692832764505, 'mean_word_length': 1.7046360394378015, 'pattern_counts': {'":': 0, '<': 5, '<?xml version=': 0, '>': 9, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 39, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '409366', 'n_tokens_mistral': 4059, 'n_tokens_neox': 3828, 'n_words': 1032}