dds/functions.rkt

#lang racket

;;; dds/functions

;;; This modules provides some definitions for working with functions:
;;; tabulating, (re)constructing from tables, generating random
;;; functions, etc.  Some definitions of particular kinds of functions
;;; are also provided (threshold Boolean functions, etc.).

(require "utils.rkt")

(module typed typed/racket
  (require "utils.rkt"
           (only-in typed/racket/unsafe unsafe-provide)
           (for-syntax syntax/parse))

  (provide
   pseudovariadic-lambda pvλ pseudovariadic-define pvdefine
   tabulate* tabulate*/strict tabulate*/pv tabulate tabulate/strict tabulate/pv)

  (unsafe-provide
   (rename-out [tabulate* tabulate*/untyped]
               [tabulate tabulate/untyped]))

  (module+ test
    (require typed/rackunit))

  (begin-for-syntax
    (require racket (for-syntax syntax/parse))

    (define (make-pseudovariadic-core args bodies tag-stx)
      (define nargs-stx (datum->syntax args (length (syntax->list args))))
      #`(λ xs
          (match xs
            [(list #,@args) #,@bodies]
            [_ (error #,tag-stx "invalid arity, expected ~a argument(s)" #,nargs-stx)])))

    (define (make-pseudovariadic-lambda stx)
      (syntax-parse stx
        [(_ (args:id ...) bodies:expr ...)
         (make-pseudovariadic-core #'(args ...)
                                   #'(bodies ...)
                                   (datum->syntax stx ''pseudovariadic-lambda))]))

    (define (make-pseudovariadic-define stx)
      (syntax-parse stx
        [(_ (name:id args:id ...) bodies:expr ...)
         #`(define name
             #,(make-pseudovariadic-core
                #'(args ...)
                #'(bodies ...)
                (datum->syntax #'name `(quote ,(syntax->datum #'name)))))])))

  (define-syntax (pseudovariadic-lambda stx) (make-pseudovariadic-lambda stx))
  (define-syntax (pvλ stx) (make-pseudovariadic-lambda stx))

  (module+ test
    (test-case "pseudovariadic-lambda")
    (check-false ((pseudovariadic-lambda (x y) (and x y)) #t #f))
    (check-false ((pvλ (x y) (and x y)) #t #f))
    (check-exn exn:fail? (λ () ((pseudovariadic-lambda (x y) (and x y)) #t #f #f)))
    (check-exn exn:fail? (λ () ((pvλ (x y) (and x y)) #t #f #f))))

  (define-syntax (pseudovariadic-define stx) (make-pseudovariadic-define stx))
  (define-syntax (pvdefine stx) (make-pseudovariadic-define stx))

  (module+ test
    (test-case "pseudovariadic-define")
    (: f (-> Boolean * Boolean))
    (pseudovariadic-define (f x y) (and x y))
    (check-false (f #t #f))
    (check-exn exn:fail? (λ () (f #t #f #f)))

    (: g (-> Boolean * Boolean))
    (pvdefine (g x y) (and x y))
    (check-false (g #t #f))
    (check-exn exn:fail? (λ () (g #t #f #f))))

  (define-syntax (make-tabulate* stx)
    (syntax-parse stx
      [(_ name:id row-op)
       #'(define (name funcs doms)
           (for/list ([xs (in-list (apply cartesian-product doms))])
             (row-op xs (for/list ([f funcs]) : (Listof b)
                                  (apply f xs)))))]))

  (: tabulate* (All (b a ... ) (-> (Listof (-> a ... b)) (List (Listof a) ... a)
                                   (Listof (Listof (U Any b))))))
  (make-tabulate* tabulate* append)

  (module+ test
    (test-case "tabulate*"
      (check-equal? (tabulate*
                     (list (λ (x y) (and x y))
                           (λ (x y) (or x y)))
                     '((#f #t) (#f #t)))
                    '((#f #f #f #f) (#f #t #f #t) (#t #f #f #t) (#t #t #t #t)))
      (check-equal? (tabulate* empty '((#f #t) (#f #t)))
                    '((#f #f) (#f #t) (#t #f) (#t #t)))))

  (: tabulate*/strict (All (b a ...) (-> (Listof (-> a ... b)) (List (Listof a) ... a)
                                         (Listof (List (List a ...) (Listof b))))))
  (make-tabulate* tabulate*/strict list)

  (module+ test
    (test-case "tabulate*/strict"
      (check-equal? (tabulate*/strict
                     (list (λ (x y) (and x y))
                           (λ (x y) (or x y)))
                     '((#f #t) (#f #t)))
                    '(((#f #f) (#f #f)) ((#f #t) (#f #t)) ((#t #f) (#f #t)) ((#t #t) (#t #t))))))


  (: tabulate*/pv (All (a b) (-> (Listof (-> a * b)) (Listof (Listof a))
                                 (Listof (Listof (U a b))))))
  (make-tabulate* tabulate*/pv append)

  (module+ test
    (test-case "tabulate*/pv"
      (check-equal? (tabulate*/pv (list (pvλ (x y) (and x y))
                                        (pvλ (x y) (or x y)))
                                  '((#f #t) (#f #t)))
                    '((#f #f #f #f) (#f #t #f #t) (#t #f #f #t) (#t #t #t #t)))))

  (: tabulate (All (b a ...) (-> (-> a ... b) (List (Listof a) ... a)
                                 (Listof (Listof (U Any b))))))
  (define (tabulate func doms)
    (tabulate* (list func) doms))

  (module+ test
    (test-case "tabulate"
      (check-equal? (tabulate (λ (x y) (and x y)) '((#f #t) (#f #t)))
                    '((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t)))))

  (: tabulate/strict (All (b a ...) (-> (-> a ... b) (List (Listof a) ... a)
                                        (Listof (List (List a ...) (Listof b))))))
  (define (tabulate/strict func doms)
    (tabulate*/strict (list func) doms))

  (module+ test
    (test-case "tabulate/strict"
      (check-equal? (tabulate/strict (λ (x y) (and x y)) '((#f #t) (#f #t)))
                    '(((#f #f) (#f)) ((#f #t) (#f)) ((#t #f) (#f)) ((#t #t) (#t))))))

  (: tabulate/pv (All (a b) (-> (-> a * b) (Listof (Listof a))
                                (Listof (Listof (U a b))))))
  (define (tabulate/pv func doms)
    (tabulate*/pv (list func) doms))

  (module+ test
    (test-case "tabulate/pv"
      (check-equal? (tabulate/pv (pvλ (x y) (and x y)) '((#f #t) (#f #t)))
                    '((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t)))))
  )

(require 'typed)
(provide
 pseudovariadic-lambda pvλ pseudovariadic-define pvdefine
 tabulate* tabulate*/strict tabulate*/pv tabulate*/untyped
 tabulate tabulate/strict tabulate/pv tabulate/untyped)


(provide
 ;; Structures
 (contract-out
  [struct tbf ((weights (vectorof number?)) (threshold number?))])
 ;; Functions
 (contract-out
  [tabulate/boolean (-> procedure? (listof (listof boolean?)))]
  [tabulate*/boolean (-> (non-empty-listof procedure?) (listof (listof boolean?)))]
  [tabulate/01 (-> procedure? (listof (listof (or/c 0 1))))]
  [tabulate*/01 (-> (non-empty-listof procedure?) (listof (listof (or/c 0 1))))]
  [table->function (-> (listof (*list/c any/c any/c)) procedure?)]
  [table->function/list (-> (listof (*list/c any/c any/c)) procedure?)]
  [enumerate-boolean-tables (-> number? (stream/c (listof (*list/c boolean? boolean?))))]
  [enumerate-boolean-functions (-> number? (stream/c procedure?))]
  [enumerate-boolean-functions/list (-> number? (stream/c procedure?))]
  [random-boolean-table (-> number? (listof (*list/c boolean? boolean?)))]
  [random-boolean-function (-> number? procedure?)]
  [random-boolean-function/list (-> number? procedure?)]
  [tbf-w (-> tbf? (vectorof number?))]
  [tbf-θ (-> tbf? number?)]
  [vector-boolean->01 (-> (vectorof boolean?) (vectorof (or/c 0 1)))]
  [apply-tbf (-> tbf? (vectorof (or/c 0 1)) (or/c 0 1))]
  [apply-tbf/boolean (-> tbf? (vectorof boolean?) boolean?)]
  [list->tbf (-> (cons/c number? (cons/c number? (listof number?))) tbf?)]
  [lists->tbfs (-> (listof (listof number?)) (listof tbf?))]
  [read-org-tbfs (->* (string?) (#:headers boolean?) (listof tbf?))]
  [tbf-tabulate* (-> (listof tbf?) (listof (listof (or/c 0 1))))]
  [tbf-tabulate (-> tbf? (listof (listof (or/c 0 1))))]
  [tbf-tabulate*/boolean (-> (listof tbf?) (listof (listof boolean?)))]
  [sbf (-> (vectorof number?) tbf?)]
  [list->sbf (-> (listof number?) sbf?)]
  [read-org-sbfs (->* (string?) (#:headers boolean?) (listof sbf?))])
 ;; Predicates
 (contract-out
  [sbf? (-> any/c boolean?)]))

(module+ test
  (require rackunit))


;;; ==========
;;; Tabulating
;;; ==========

;;; Like tabulate, but assumes the domains of all variables of the
;;; function are Boolean.  func must have a fixed arity.  It is an
;;; error to supply a function of variable arity.
(define (tabulate/boolean func)
  (tabulate/untyped func (make-list (procedure-arity func) '(#f #t))))

(module+ test
  (test-case "tabulate/boolean"
    (check-equal? (tabulate/boolean (lambda (x y) (and x y)))
                  '((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t)))))

;;; Like tabulate/boolean, but takes a list of functions of the same
;;; arity.
(define (tabulate*/boolean funcs)
  (define doms (make-list (procedure-arity (car funcs)) '(#f #t)))
  (tabulate*/untyped funcs doms))

(module+ test
  (test-case "tabulate*/boolean"
    (check-equal? (tabulate*/boolean `(,(λ (x y) (and x y))
                                       ,(λ (x y) (or x y))))
                  '((#f #f #f #f) (#f #t #f #t) (#t #f #f #t) (#t #t #t #t)))))

;;; Like tabulate, but assumes the domains of all variables of the
;;; function are {0, 1}.  func must have a fixed arity.  It is an
;;; error to supply a function of variable arity.
(define (tabulate/01 func)
  (tabulate/untyped func (make-list (procedure-arity func) '(0 1))))

(module+ test
  (test-case "tabulate/01"
    (check-equal? (tabulate/01 (λ (x y) (modulo (+ x y) 2)))
                  '((0 0 0) (0 1 1) (1 0 1) (1 1 0)))))

;;; Like tabulate/01, but takes a list of functions of the same arity.
(define (tabulate*/01 funcs)
  (tabulate*/untyped funcs (make-list (procedure-arity (car funcs)) '(0 1))))

(module+ test
  (test-case "tabulate*/01"
    (check-equal? (tabulate*/01 `(,(λ (x y) (min x y)) ,(λ (x y) (max x y))))
                  '((0 0 0 0) (0 1 0 1) (1 0 0 1) (1 1 1 1)))))

;;; ======================
;;; Constructing functions
;;; ======================

;;; Given a table like the one produced by the tabulate functions,
;;; creates a function which has this behaviour.
;;;
;;; More exactly, the input is a list of lists of values.  All but the
;;; last elements of every list give the values of the parameters of
;;; the function, while the the last element of every list gives the
;;; value of the function.  Thus, every list should have at least two
;;; elements.
;;;
;;; The produced function is implemented via lookups in hash tables,
;;; meaning that it may be sometimes more expensive to compute than by
;;; using an direct symbolic implementation.
(define (table->function table)
  (let ([func (table->function/list table)])
    (λ args (func args))))

(module+ test
  (test-case "table->function"
    (define negation (table->function '((#t #f) (#f #t))))
    (check-true (negation #f))
    (check-false (negation #t))))

;;; Like table->function, but the produced function accepts a single
;;; list of arguments instead of individual arguments.
(define (table->function/list table)
  ((curry hash-ref)
   (for/hash ([line table])
     (let-values ([(x fx) (split-at-right line 1)])
       (values x (car fx))))))

(module+ test
  (test-case "table->function/list"
    (define negation/list (table->function/list '((#t #f) (#f #t))))
    (check-true (negation/list '(#f)))
    (check-false (negation/list '(#t)))))

;;; Returns the stream of the truth tables of all Boolean functions of
;;; a given arity.
;;;
;;; There are 2^(2^n) Boolean functions of arity n.
(define (enumerate-boolean-tables n)
  (let ([inputs (boolean-power/stream n)]
        [outputs (boolean-power/stream (expt 2 n))])
    (for/stream ([out (in-stream outputs)])
      (for/list ([in (in-stream inputs)] [o out])
        (append in (list o))))))

;;; Returns the stream of all Boolean functions of a given arity.
;;;
;;; There are 2^(2^n) Boolean functions of arity n.
(define (enumerate-boolean-functions n)
  (stream-map table->function (enumerate-boolean-tables n)))

(module+ test
  (test-case "enumerate-boolean-tables"
    (define f1 (stream-first (enumerate-boolean-functions 1)))
    (check-false (f1 #f))
    (check-false (f1 #t))))

;;; Returns the stream of all Boolean functions of a given arity.  As
;;; different from the functions returned by
;;; enumerate-boolean-functions, the functions take lists of arguments
;;; instead of n arguments.
;;;
;;; There are 2^(2^n) Boolean functions of arity n.
(define (enumerate-boolean-functions/list n)
  (stream-map table->function/list (enumerate-boolean-tables n)))

(module+ test
  (test-case "enumerate-boolean-functions/list"
    (define f1/list (stream-first (enumerate-boolean-functions/list 1)))
    (check-false (f1/list '(#f)))
    (check-false (f1/list '(#t)))))


;;; ================
;;; Random functions
;;; ================

;;; Generates a random truth table for a Boolean function of arity n.
(define (random-boolean-table n)
  (define/match (num->bool x) [(0) #f] [(1) #t])
  (define inputs (boolean-power n))
  (define outputs (stream-take (in-random 2) (expt 2 n)))
  (for/list ([i inputs] [o outputs])
    (append i (list (num->bool o)))))

(module+ test
  (test-case "random-boolean-table"
    (random-seed 0)
    (check-equal? (random-boolean-table 2) '((#f #f #t) (#f #t #t) (#t #f #f) (#t #t #f)))))

;;; Generates a random Boolean function of arity n.
(define random-boolean-function (compose table->function random-boolean-table))

(module+ test
  (test-case "random-boolean-function"
    (define f (random-boolean-function 2))
    (check-true (f #f #f)) (check-false (f #f #t))
    (check-true (f #t #f)) (check-false (f #t #t))))

;;; Like random-boolean-function, but the constructed function takes a
;;; list of arguments.
(define random-boolean-function/list (compose table->function/list random-boolean-table))

(module+ test
  (test-case "random-boolean-function/list"
    (define f (random-boolean-function/list 2))
    (check-false (f '(#f #f))) (check-true (f '(#f #t)))
    (check-true (f '(#t #f))) (check-false (f '(#t #t)))))


;;; ===========================
;;; Threshold Boolean functions
;;; ===========================

;;; A threshold Boolean function (TBF) is a pair (w, θ), where w is a
;;; vector of weights and θ is the threshold.
(struct tbf (weights threshold) #:transparent)

;;; Unicode shortcuts for accessing the elements of a TBF.
(define tbf-w tbf-weights)
(define tbf-θ tbf-threshold)

;;; Converts a Boolean vector to a 0-1 vector.
(define (vector-boolean->01 bool-v)
  (vector-map any->01 bool-v))

(module+ test
  (test-case "boolean->0-1"
    (check-equal? (vector-boolean->01 #(#t #f #f)) #(1 0 0))))

;;; Applies the TBF to its inputs.
;;;
;;; Applying a TBF consists in multiplying the weights by the
;;; corresponding inputs and comparing the sum of the products to the
;;; threshold.
(define (apply-tbf tbf inputs)
  (any->01
   (>
    ;; The scalar product between the inputs and the weights
    (for/sum ([x (in-vector inputs)]
              [w (in-vector (tbf-w tbf))])
      (* x w))
    (tbf-θ tbf))))

(module+ test
  (test-case "apply-tbf"
    (define f1 (tbf #(2 -2) 1))
    (check-equal? (tabulate/01 (λ (x y) (apply-tbf f1 (vector x y))))
                  '((0 0 0) (0 1 0) (1 0 1) (1 1 0)))))

;;; Like apply-tbf, but takes Boolean values as inputs and outputs a
;;; boolean value.
(define (apply-tbf/boolean tbf inputs)
  (01->boolean (apply-tbf tbf (vector-map any->01 inputs))))

(module+ test
  (test-case "apply-tbf/boolean"
    (define f1 (tbf #(2 -2) 1))
    (check-equal? (tabulate/boolean (λ (x y) (apply-tbf/boolean f1 (vector x y))))
                  '((#f #f #f) (#f #t #f) (#t #f #t) (#t #t #f)))))

;;; Converts a list of numbers to a TBF.  The last element of the list
;;; is taken to be the threshold, while the other elements are taken
;;; to be the weights.
(define (list->tbf lst)
  (define-values (w θ) (split-at-right lst 1))
  (tbf (list->vector w) (car θ)))

(module+ test
  (test-case "list->tbf"
    (check-equal? (list->tbf '(1 2 3)) (tbf #(1 2) 3))))

;;; Reads a list of TBF from an Org-mode table read by
;;; read-org-sexp.
(define lists->tbfs ((curry map) list->tbf))

(module+ test
  (test-case "read-tbfs"
    (check-equal? (lists->tbfs '((1 2 3) (2 3 4)))
                  (list (tbf '#(1 2) 3) (tbf '#(2 3) 4)))))

;;; Reads a list of TBF from an Org-mode string containing a sexp,
;;; containing a list of lists of numbers.  If headers is #t, drops
;;; the first list, supposing that it contains the headers of the
;;; table.
;;;
;;; The input is typically what read-org-sexp reads.
(define (read-org-tbfs str #:headers [headers #f])
  (define sexp (read-org-sexp str))
  (define sexp-clean (cond [headers (cdr sexp)] [else sexp]))
  (lists->tbfs sexp-clean))

(module+ test
  (test-case "read-org-tbfs"
    (check-equal? (read-org-tbfs "((1 2 1) (1 0 1))")
                  (list (tbf '#(1 2) 1) (tbf '#(1 0) 1)))))

;;; Tabulates a list of TBFs.
;;;
;;; The result is a list of lists describing the truth table of the
;;; given TBFs.  The first elements of each line give the values of
;;; the inputs, while the last elements give the values of each the
;;; functions corresponding to the input.
;;;
;;; All the TBFs in tbfs must have the same number of inputs as the
;;; first TBF in the list.  This function does not check this
;;; condition.
(define (tbf-tabulate* tbfs)
  (define funcs (for/list ([tbf tbfs])
                  (λ in (apply-tbf tbf (list->vector in)))))
  (define nvars (vector-length (tbf-w (car tbfs))))
  (tabulate*/untyped funcs (make-list nvars '(0 1))))

(module+ test
  (test-case "tbf-tabulate*"
    (check-equal? (tbf-tabulate* (list (tbf #(2 2) 1) (tbf #(1 1) 1)))
                  '((0 0 0 0) (0 1 1 0) (1 0 1 0) (1 1 1 1)))))

;;; Tabulates a TBF.
(define tbf-tabulate (compose tbf-tabulate* list))

(module+ test
  (test-case "tbf-tabulate"
    (check-equal? (tbf-tabulate (tbf #(1 2) 1))
                  '((0 0 0) (0 1 1) (1 0 0) (1 1 1)))))

;;; Tabulates a list of TBFs like tbf-boolean*, but uses Boolean
;;; values #f and #t instead of 0 and 1.
;;;
;;; All the TBFs in tbfs must have the same number of inputs as the
;;; first TBF in the list.  This function does not check this
;;; condition.
(define (tbf-tabulate*/boolean tbfs)
  (define funcs (for/list ([tbf tbfs])
                  (λ in (apply-tbf/boolean tbf (list->vector in)))))
  (define nvars (vector-length (tbf-w (car tbfs))))
  (tabulate*/untyped funcs (make-list nvars '(#f #t))))

(module+ test
  (test-case "tbf-tabulate*/boolean"
    (check-equal? (tbf-tabulate*/boolean `(,(tbf #(1 2) 1)))
                  '((#f #f #f) (#f #t #t) (#t #f #f) (#t #t #t)))))

;;; A sign Boolean function (SBF) is a TBF whose threshold is 0.
(define sbf? (and/c tbf? (λ (x) (= 0 (tbf-θ x)))))

(module+ test
  (test-case "sbf?"
    (check-false (sbf? (tbf #(1 2) 3)))
    (check-true (sbf? (tbf #(1 2) 0)))))

;;; Creates a TBF which is an SBF from a vector of weights.
(define (sbf w) (tbf w 0))

(module+ test
  (test-case "sbf"
    (check-equal? (sbf #(1 -1)) (tbf '#(1 -1) 0))))

;;; Converts a list of numbers to an SBF.  The elements of the list
;;; are taken to be the weights of the SBF.
(define list->sbf (compose sbf list->vector))

(module+ test
  (test-case "list->sbf"
    (check-equal? (list->sbf '(1 -1)) (tbf '#(1 -1) 0))))

;;; Reads a list of SBF from an Org-mode string containing a sexp,
;;; containing a list of lists of numbers.  If headers is #t, drops
;;; the first list, supposing that it contains the headers of the
;;; table.
;;;
;;; The input is typically what read-org-sexp reads.
(define (read-org-sbfs str #:headers [headers #f])
  (define sexp (read-org-sexp str))
  (define sexp-clean (cond [headers (cdr sexp)] [else sexp]))
  (map list->sbf sexp-clean))

(module+ test
  (test-case "read-org-sbfs"
    (check-equal? (read-org-sbfs "((1 1) (1 -1))")
                  (list (tbf '#(1 1) 0) (tbf '#(1 -1) 0)))))