696 lines
27 KiB
Racket
696 lines
27 KiB
Racket
#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"
|
|
syntax/parse/define typed/racket/stream
|
|
(only-in typed/racket/unsafe unsafe-provide)
|
|
(for-syntax syntax/parse))
|
|
|
|
(require/typed racket/stream
|
|
[stream-map (All (a b) (-> (-> a b) (Sequenceof a) (Sequenceof b)))])
|
|
|
|
(provide
|
|
pseudovariadic-lambda pvλ pseudovariadic-define pvdefine
|
|
tabulate* tabulate*/strict tabulate*/pv tabulate tabulate/strict tabulate/pv
|
|
tabulate*/pv/boolean tabulate/pv/boolean tabulate*/pv/01 tabulate/pv/01
|
|
tabulate*/list tabulate/list
|
|
tabulate*/list/boolean tabulate/list/boolean tabulate*/list/01 tabulate/list/01
|
|
table->function/list table->function table->function/pv
|
|
enumerate-boolean-tables enumerate-boolean-functions
|
|
enumerate-boolean-functions/pv enumerate-boolean-functions/list
|
|
random-boolean-table random-boolean-function random-boolean-function/list
|
|
|
|
(struct-out tbf) tbf-w tbf-θ boolean->01/vector apply-tbf apply-tbf/boolean
|
|
list->tbf lists->tbfs read-org-tbfs tbf-tabulate*)
|
|
|
|
(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-parse-rule (make-tabulate* name:id row-op:id apply-op:id)
|
|
(define (name funcs doms)
|
|
(for/list ([xs (in-list (apply cartesian-product doms))])
|
|
(row-op xs (for/list ([f funcs]) : (Listof b)
|
|
(apply-op f xs))))))
|
|
|
|
(: tabulate* (All (b a ... ) (-> (Listof (-> a ... b)) (List (Listof a) ... a)
|
|
(Listof (Listof (U Any b))))))
|
|
(make-tabulate* tabulate* append apply)
|
|
|
|
(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 apply)
|
|
|
|
(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 apply)
|
|
|
|
(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)))))
|
|
|
|
(define-syntax-parse-rule (simple-apply func:expr arg:expr)
|
|
(func arg))
|
|
|
|
(: tabulate*/list (All (a b) (-> (Listof (-> (Listof a) b)) (Listof (Listof a))
|
|
(Listof (Listof (U a b))))))
|
|
(make-tabulate* tabulate*/list append simple-apply)
|
|
|
|
(module+ test
|
|
(test-case "tabulate*/list"
|
|
(check-equal? (tabulate*/list (list (λ ([xs : (Listof Boolean)])
|
|
(and (car xs) (cadr xs)))
|
|
(λ ([xs : (Listof Boolean)])
|
|
(or (car xs) (cadr xs))))
|
|
'((#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)))))
|
|
|
|
(: tabulate/list (All (a b) (-> (-> (Listof a) b) (Listof (Listof a))
|
|
(Listof (Listof (U a b))))))
|
|
(define (tabulate/list func doms)
|
|
(tabulate*/list (list func) doms))
|
|
|
|
(module+ test
|
|
(test-case "tabulate/list"
|
|
(check-equal? (tabulate/list (λ ([xs : (Listof Boolean)])
|
|
(and (car xs) (cadr xs)))
|
|
'((#f #t) (#f #t)))
|
|
'((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t)))))
|
|
|
|
(: tabulate/pv/boolean (-> Positive-Integer (-> Boolean * Boolean) (Listof (Listof Boolean))))
|
|
(define (tabulate/pv/boolean arity func)
|
|
(tabulate/pv func (make-list arity '(#f #t))))
|
|
|
|
(module+ test
|
|
(test-case "tabulate/pv/boolean"
|
|
(check-equal? (tabulate/pv/boolean 2 (pvλ (x y) (and x y)))
|
|
'((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t)))))
|
|
|
|
(: tabulate*/pv/boolean (-> Positive-Integer (Listof (-> Boolean * Boolean))
|
|
(Listof (Listof Boolean))))
|
|
(define (tabulate*/pv/boolean arity funcs)
|
|
(tabulate*/pv funcs (make-list arity '(#f #t))))
|
|
|
|
(module+ test
|
|
(test-case "tabulate*/pv/boolean"
|
|
(check-equal? (tabulate*/pv/boolean 2 (list (pvλ (x y) (and x y))
|
|
(pvλ (x y) (or x y))))
|
|
'((#f #f #f #f) (#f #t #f #t) (#t #f #f #t) (#t #t #t #t)))))
|
|
|
|
(: tabulate/pv/01 (-> Positive-Integer (-> (U Zero One) * (U Zero One))
|
|
(Listof (Listof (U Zero One)))))
|
|
(define (tabulate/pv/01 arity func)
|
|
(tabulate/pv func (make-list arity '(0 1))))
|
|
|
|
(module+ test
|
|
(test-case "tabulate/pv/01"
|
|
(check-equal? (tabulate/pv/01 2 (pvλ (x y)
|
|
(assert-type (modulo (+ x y) 2) (U Zero One))))
|
|
'((0 0 0) (0 1 1) (1 0 1) (1 1 0)))))
|
|
|
|
(: tabulate*/pv/01 (-> Positive-Integer (Listof (-> (U Zero One) * (U Zero One)))
|
|
(Listof (Listof (U Zero One)))))
|
|
(define (tabulate*/pv/01 arity funcs)
|
|
(tabulate*/pv funcs (make-list arity '(0 1))))
|
|
|
|
(module+ test
|
|
(test-case "tabulate*/pv/01"
|
|
(check-equal? (tabulate*/pv/01 2 `(,(pvλ (x y) (assert-type (min x y) (U Zero One)))
|
|
,(pvλ (x y) (assert-type (max x y) (U Zero One)))))
|
|
'((0 0 0 0) (0 1 0 1) (1 0 0 1) (1 1 1 1)))))
|
|
|
|
(: tabulate/list/boolean (-> Positive-Integer (-> (Listof Boolean) Boolean)
|
|
(Listof (Listof Boolean))))
|
|
(define (tabulate/list/boolean arity func)
|
|
(tabulate/list func (make-list arity '(#f #t))))
|
|
|
|
(module+ test
|
|
(test-case "tabulate/list/boolean"
|
|
(check-equal? (tabulate/list/boolean 2 (λ (xs) (and (car xs) (cadr xs))))
|
|
'((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t)))))
|
|
|
|
(: tabulate*/list/boolean (-> Positive-Integer (Listof (-> (Listof Boolean) Boolean))
|
|
(Listof (Listof Boolean))))
|
|
(define (tabulate*/list/boolean arity funcs)
|
|
(tabulate*/list funcs (make-list arity '(#f #t))))
|
|
|
|
(module+ test
|
|
(test-case "tabulate*/list/boolean"
|
|
(check-equal?
|
|
(tabulate*/list/boolean 2 (list (λ (xs) (and (car xs) (cadr xs)))
|
|
(λ (xs) (or (car xs) (cadr xs)))))
|
|
'((#f #f #f #f) (#f #t #f #t) (#t #f #f #t) (#t #t #t #t)))))
|
|
|
|
(: tabulate/list/01 (-> Positive-Integer (-> (Listof (U Zero One)) (U Zero One))
|
|
(Listof (Listof (U Zero One)))))
|
|
(define (tabulate/list/01 arity func)
|
|
(tabulate/list func (make-list arity '(0 1))))
|
|
|
|
(module+ test
|
|
(test-case "tabulate/list/01"
|
|
(check-equal?
|
|
(tabulate/list/01 2 (λ (xs)
|
|
(assert-type (modulo (+ (car xs) (cadr xs)) 2) (U Zero One))))
|
|
'((0 0 0) (0 1 1) (1 0 1) (1 1 0)))))
|
|
|
|
(: tabulate*/list/01 (-> Positive-Integer (Listof (-> (Listof (U Zero One)) (U Zero One)))
|
|
(Listof (Listof (U Zero One)))))
|
|
(define (tabulate*/list/01 arity funcs)
|
|
(tabulate*/list funcs (make-list arity '(0 1))))
|
|
|
|
(module+ test
|
|
(test-case "tabulate*/list/01"
|
|
(check-equal? (tabulate*/list/01
|
|
2
|
|
`(,(λ (xs) (assert-type (min (car xs) (cadr xs)) (U Zero One)))
|
|
,(λ (xs) (assert-type (max (car xs) (cadr xs)) (U Zero One)))))
|
|
'((0 0 0 0) (0 1 0 1) (1 0 0 1) (1 1 1 1)))))
|
|
|
|
(: table->function/list (All (a) (-> (Listof (Listof a))
|
|
(-> (Listof a) a))))
|
|
(define (table->function/list table)
|
|
(define ht-tab
|
|
(for/hash ([line (in-list table)]) : (HashTable (Listof a) a)
|
|
(define-values (x fx) (split-at-right line 1))
|
|
(values x (car fx))))
|
|
(λ (x) (hash-ref ht-tab x)))
|
|
|
|
(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)))))
|
|
|
|
(: table->function (All (a) (-> (Listof (Listof a)) (-> a * a))))
|
|
(define (table->function table)
|
|
(define 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))))
|
|
|
|
(: table->function/pv (All (a) (-> (Listof (Listof a)) (-> a * a))))
|
|
(define (table->function/pv table)
|
|
(define func (table->function/list table))
|
|
(define arity (- (length (car table)) 1))
|
|
(λ xs
|
|
(if (= arity (length xs))
|
|
(func xs)
|
|
(error 'pseudovariadic-lambda
|
|
"invalid arity, expected ~a argument(s)"
|
|
arity))))
|
|
|
|
(module+ test
|
|
(test-case "table->function/pv"
|
|
(define negation (table->function/pv '((#t #f) (#f #t))))
|
|
(check-true (negation #f))
|
|
(check-false (negation #t))
|
|
(check-exn exn:fail? (λ () (negation #f #t)))))
|
|
|
|
(: enumerate-boolean-tables (-> Positive-Integer (Sequenceof (Listof (Listof Boolean)))))
|
|
(define (enumerate-boolean-tables n)
|
|
(define inputs (boolean-power n))
|
|
(define outputs (boolean-power/stream (assert-type (expt 2 n) Integer)))
|
|
|
|
(: append-outputs (-> (Listof (Listof Boolean)) (Listof Boolean)
|
|
(Listof (Listof Boolean))))
|
|
(define (append-outputs ins outs)
|
|
(for/list ([row ins] [o outs]) (append row (list o))))
|
|
|
|
(: yield (-> (Sequenceof (Listof Boolean)) (Sequenceof (Listof (Listof Boolean)))))
|
|
(define (yield rest-outputs)
|
|
(if (stream-empty? rest-outputs)
|
|
(stream)
|
|
(stream-cons (append-outputs inputs (stream-first rest-outputs))
|
|
(yield (stream-rest rest-outputs)))))
|
|
|
|
(yield outputs))
|
|
|
|
(module+ test
|
|
(test-case "enumerate-boolean-tables"
|
|
(check-equal? (stream->list (enumerate-boolean-tables 2))
|
|
'(((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #f))
|
|
((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t))
|
|
((#f #f #f) (#f #t #f) (#t #f #t) (#t #t #f))
|
|
((#f #f #f) (#f #t #f) (#t #f #t) (#t #t #t))
|
|
((#f #f #f) (#f #t #t) (#t #f #f) (#t #t #f))
|
|
((#f #f #f) (#f #t #t) (#t #f #f) (#t #t #t))
|
|
((#f #f #f) (#f #t #t) (#t #f #t) (#t #t #f))
|
|
((#f #f #f) (#f #t #t) (#t #f #t) (#t #t #t))
|
|
((#f #f #t) (#f #t #f) (#t #f #f) (#t #t #f))
|
|
((#f #f #t) (#f #t #f) (#t #f #f) (#t #t #t))
|
|
((#f #f #t) (#f #t #f) (#t #f #t) (#t #t #f))
|
|
((#f #f #t) (#f #t #f) (#t #f #t) (#t #t #t))
|
|
((#f #f #t) (#f #t #t) (#t #f #f) (#t #t #f))
|
|
((#f #f #t) (#f #t #t) (#t #f #f) (#t #t #t))
|
|
((#f #f #t) (#f #t #t) (#t #f #t) (#t #t #f))
|
|
((#f #f #t) (#f #t #t) (#t #f #t) (#t #t #t))))))
|
|
|
|
(: enumerate-boolean-functions (-> Positive-Integer (Sequenceof (-> Boolean * Boolean))))
|
|
(define (enumerate-boolean-functions n)
|
|
(stream-map (inst table->function Boolean) (enumerate-boolean-tables n)))
|
|
|
|
(module+ test
|
|
(test-case "enumerate-boolean-functions"
|
|
(define bool-f1 (stream-first (enumerate-boolean-functions 1)))
|
|
(check-false (bool-f1 #f))
|
|
(check-false (bool-f1 #t))))
|
|
|
|
(: enumerate-boolean-functions/pv (-> Positive-Integer (Sequenceof (-> Boolean * Boolean))))
|
|
(define (enumerate-boolean-functions/pv n)
|
|
(stream-map (inst table->function/pv Boolean) (enumerate-boolean-tables n)))
|
|
|
|
(module+ test
|
|
(test-case "enumerate-boolean-functions/pv"
|
|
(define bool-f1/pv (stream-first (enumerate-boolean-functions/pv 1)))
|
|
(check-false (bool-f1/pv #f))
|
|
(check-false (bool-f1/pv #t))
|
|
(check-exn exn:fail? (λ () (bool-f1/pv #f #f)))))
|
|
|
|
(: enumerate-boolean-functions/list
|
|
(-> Positive-Integer (Sequenceof (-> (Listof Boolean) Boolean))))
|
|
(define (enumerate-boolean-functions/list n)
|
|
(stream-map (inst table->function/list Boolean) (enumerate-boolean-tables n)))
|
|
|
|
(module+ test
|
|
(test-case "enumerate-boolean-functions/list"
|
|
(define bool-f1/list (stream-first (enumerate-boolean-functions/list 1)))
|
|
(check-false (bool-f1/list '(#f)))
|
|
(check-false (bool-f1/list '(#t)))))
|
|
|
|
(: random-boolean-table (-> Positive-Integer (Listof (Listof Boolean))))
|
|
(define (random-boolean-table n)
|
|
(define ins (boolean-power n))
|
|
(define outs (stream-take (in-random 2) (assert-type (expt 2 n) Nonnegative-Integer)))
|
|
(for/list ([i ins] [o outs])
|
|
(append i (list (if (= o 1) #t #f)))))
|
|
|
|
(module+ test
|
|
(test-case "random-boolean-table"
|
|
(random-seed 1)
|
|
(check-equal? (random-boolean-table 2)
|
|
'((#f #f #t)
|
|
(#f #t #t)
|
|
(#t #f #f)
|
|
(#t #t #t)))))
|
|
|
|
(: random-boolean-function (-> Positive-Integer (-> Boolean * Boolean)))
|
|
(define (random-boolean-function n)
|
|
(table->function (random-boolean-table n)))
|
|
|
|
(module+ test
|
|
(test-case "random-boolean-function"
|
|
(random-seed 1)
|
|
(define random-bool-f (random-boolean-function 2))
|
|
(check-true (random-bool-f #f #f))
|
|
(check-true (random-bool-f #f #t))
|
|
(check-false (random-bool-f #t #f))
|
|
(check-true (random-bool-f #t #t))))
|
|
|
|
(: random-boolean-function/list (-> Positive-Integer (-> (Listof Boolean) Boolean)))
|
|
(define (random-boolean-function/list n)
|
|
(table->function/list (random-boolean-table n)))
|
|
|
|
(module+ test
|
|
(test-case "random-boolean-function/list"
|
|
(random-seed 1)
|
|
(define random-bool-f/list (random-boolean-function/list 2))
|
|
(check-true (random-bool-f/list '(#f #f)))
|
|
(check-true (random-bool-f/list '(#f #t)))
|
|
(check-false (random-bool-f/list '(#t #f)))
|
|
(check-true (random-bool-f/list '(#t #t)))))
|
|
|
|
(struct tbf ([weights : (Vectorof Real)] [threshold : Real]) #:transparent)
|
|
(define tbf-w tbf-weights)
|
|
(define tbf-θ tbf-threshold)
|
|
|
|
(: boolean->01/vector (-> (Vectorof Boolean) (Vectorof (U Zero One))))
|
|
(define (boolean->01/vector bool-v)
|
|
(vector-map (λ (x) (any->01 x)) bool-v))
|
|
|
|
(module+ test
|
|
(test-case "boolean->01/vector"
|
|
(check-equal? (boolean->01/vector #(#t #f #f)) #(1 0 0))))
|
|
|
|
(: apply-tbf (-> tbf (Vectorof (U Zero One)) (U Zero One)))
|
|
(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))]) : Real
|
|
(* x w))
|
|
(tbf-θ tbf))))
|
|
|
|
(module+ test
|
|
(test-case "apply-tbf"
|
|
(define f1 (tbf #(2 -2) 1))
|
|
(check-equal? (tabulate/pv/01 2 (pvλ (x y) (apply-tbf f1 (vector x y))))
|
|
'((0 0 0) (0 1 0) (1 0 1) (1 1 0)))))
|
|
|
|
(: apply-tbf/boolean (-> tbf (Vectorof Boolean) Boolean))
|
|
(define (apply-tbf/boolean tbf inputs)
|
|
(01->boolean (apply-tbf tbf (boolean->01/vector inputs))))
|
|
|
|
(module+ test
|
|
(test-case "apply-tbf/boolean"
|
|
(define f1 (tbf #(2 -2) 1))
|
|
(check-equal? (tabulate/pv/boolean 2 (pvλ (x y) (apply-tbf/boolean f1 (vector x y))))
|
|
'((#f #f #f) (#f #t #f) (#t #f #t) (#t #t #f)))))
|
|
|
|
(: list->tbf (-> (Listof Real) tbf))
|
|
(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))))
|
|
|
|
(: lists->tbfs (-> (Listof (Listof Real)) (Listof tbf)))
|
|
(define (lists->tbfs lsts)
|
|
(map list->tbf lsts))
|
|
|
|
(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)))))
|
|
|
|
(: read-org-tbfs (->* (String) (#:headers Boolean) (Listof tbf)))
|
|
(define (read-org-tbfs str #:headers [headers #f])
|
|
(define sexp (assert-type (read-org-sexp str) (Listof Any)))
|
|
(define sexp-clean (cond [headers (cdr sexp)] [else sexp]))
|
|
(lists->tbfs (assert-type sexp-clean (Listof (Listof Real)))))
|
|
|
|
(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)))))
|
|
|
|
(: tbf-tabulate* (-> (Listof tbf) (Listof (Listof (U Zero One)))))
|
|
(define (tbf-tabulate* tbfs)
|
|
(define funcs (for/list ([tbf tbfs])
|
|
: (Listof (-> (Listof (U Zero One)) (U Zero One)))
|
|
(λ ([in : (Listof (U Zero One))])
|
|
(apply-tbf tbf (list->vector in)))))
|
|
(define nvars (vector-length (tbf-w (car tbfs))))
|
|
(tabulate*/list 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)))))
|
|
|
|
(module untyped racket
|
|
(module+ test
|
|
(require rackunit))
|
|
|
|
(provide
|
|
(contract-out [tabulate* (-> (listof procedure?) (listof (listof any/c))
|
|
(listof (listof any/c)))]
|
|
[tabulate (-> procedure? (listof (listof any/c))
|
|
(listof (listof any/c)))]
|
|
[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))))]))
|
|
|
|
(define (tabulate* funcs doms)
|
|
(for/list ([xs (in-list (apply cartesian-product doms))])
|
|
(append xs (for/list ([f funcs])
|
|
(apply f xs)))))
|
|
|
|
(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)))))
|
|
|
|
(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)))))
|
|
|
|
(define (tabulate/boolean func)
|
|
(tabulate 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)))))
|
|
|
|
(define (tabulate*/boolean funcs)
|
|
(define doms (make-list (procedure-arity (car funcs)) '(#f #t)))
|
|
(tabulate* 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)))))
|
|
|
|
(define (tabulate/01 func)
|
|
(tabulate 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)))))
|
|
|
|
(define (tabulate*/01 funcs)
|
|
(tabulate* 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)))))
|
|
)
|
|
)
|
|
|
|
(require 'typed)
|
|
(provide
|
|
pseudovariadic-lambda pvλ pseudovariadic-define pvdefine
|
|
tabulate* tabulate*/strict tabulate*/pv
|
|
tabulate tabulate/strict tabulate/pv
|
|
tabulate*/pv/boolean tabulate/pv/boolean
|
|
tabulate*/pv/01 tabulate/pv/01
|
|
tabulate*/list tabulate/list
|
|
tabulate*/list/boolean tabulate/list/boolean tabulate*/list/01 tabulate/list/01
|
|
table->function/list table->function table->function/pv
|
|
enumerate-boolean-tables enumerate-boolean-functions
|
|
enumerate-boolean-functions/pv enumerate-boolean-functions/list
|
|
random-boolean-table random-boolean-function random-boolean-function/list
|
|
|
|
(struct-out tbf) tbf-w tbf-θ boolean->01/vector apply-tbf apply-tbf/boolean
|
|
list->tbf lists->tbfs read-org-tbfs tbf-tabulate*)
|
|
|
|
(require (rename-in (submod 'typed untyped)
|
|
[tabulate tabulate/untyped]
|
|
[tabulate* tabulate*/untyped]))
|
|
|
|
(provide
|
|
;; Functions
|
|
(contract-out
|
|
[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))
|
|
|
|
|
|
;;; ===========================
|
|
;;; Threshold Boolean functions
|
|
;;; ===========================
|
|
|
|
|
|
;;; 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)))))
|