123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532 |
- #| -*-Scheme-*-
- Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
- Institute of Technology
- This file is part of MIT/GNU Scheme.
- MIT/GNU Scheme is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or (at
- your option) any later version.
- MIT/GNU Scheme is distributed in the hope that it will be useful, but
- WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- General Public License for more details.
- You should have received a copy of the GNU General Public License
- along with MIT/GNU Scheme; if not, write to the Free Software
- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
- USA.
- |#
- ;;;; Literal function descriptor language.
- ;;; This file is case sensitive.
- ;;; The descriptors for literal functions look like prefix versions of
- ;;; the standard function types. Thus, we want to be able to say:
- ;;; (literal-function 'V (-> (X Real Real) Real))
- ;;; The base types are the real numbers, designated by "Real". We
- ;;; will later extend the system to include complex numbers,
- ;;; designated by "Complex".
- ;;; Types can be combined in several ways. The cartesian product of
- ;;; types is designated by:
- ;;; (X <type1> <type2> ...)
- ;;; We use this to specify an argument tuple of objects of the given
- ;;; types arranged in the given order.
- ;;; Similarly, we can specify an up tuple or a down tuple with:
- ;;; (UP <type1> <type2> ...)
- ;;; (DOWN <type1> <type2> ...)
- ;;; We can also specify a uniform tuple of a number of elements of the
- ;;; same type using:
- ;;; (UP* <type> [n])
- ;;; (DOWN* <type> [n])
- #|
- ;;; So, for example:
- (define H
- (literal-function 'H
- (-> (UP Real (UP* Real 2) (DOWN* Real 2)) Real)))
- (show-expression
- (((Hamilton-equations H)
- (coordinate-tuple (literal-function 'x)
- (literal-function 'y))
- (momentum-tuple (literal-function 'p_x)
- (literal-function 'p_y)))
- 't))
- (up
- 0
- (up
- (+ ((D x) t)
- (* -1
- (((partial 2 0) H) (up t (up (x t) (y t)) (down (p_x t) (p_y t))))))
- (+ ((D y) t)
- (* -1
- (((partial 2 1) H) (up t (up (x t) (y t)) (down (p_x t) (p_y t)))))))
- (down
- (+ ((D p_x) t)
- (((partial 1 0) H) (up t (up (x t) (y t)) (down (p_x t) (p_y t)))))
- (+ ((D p_y) t)
- (((partial 1 1) H) (up t (up (x t) (y t)) (down (p_x t) (p_y t)))))))
- |#
- ;;; To get started... Type expressions are self-evaluating
- (define Real 'Real)
- (define (X . types)
- (cond ((null? types) (error "Null type argument -- X"))
- ((null? (cdr types)) (car types))
- (else (cons 'X types))))
- (define (UP . types)
- (cond ((null? types) (error "Null type argument -- UP"))
- ((null? (cdr types)) (car types))
- (else (cons 'UP types))))
- (define (DOWN . types)
- (cond ((null? types) (error "Null type argument -- DOWN"))
- ((null? (cdr types)) (car types))
- (else (cons 'DOWN types))))
- (define (^ type n) ;n = dimension
- (apply X (make-list n type)))
- (define (starify rest starred unstarred-proc)
- (cond ((null? rest) (error "Null type argument" starred))
- (else
- (let lp ((args rest) (curtype #f) (explicit #f) (types '()))
- (cond ((null? args)
- (if explicit (apply unstarred-proc types) (cons starred types)))
- ((exact-positive-integer? (car args))
- (if curtype
- (lp (cdr args)
- #f
- #t
- (append types (make-list (fix:- (car args) 1) curtype)))
- (error "Bad type arguments" starred rest)))
- (else
- (lp (cdr args)
- (car args)
- #f
- (append types (list (car args))))))))))
- (define (X* . rest)
- (starify rest 'X* X))
- (define (UP* . rest)
- (starify rest 'UP* UP))
- (define (DOWN* . rest)
- (starify rest 'DOWN* DOWN))
- (define (-> domain range)
- `(-> ,domain ,range))
- (define Any 'Any)
- (define* (default-function-type n #:optional type)
- (if (= n 1)
- '(-> Real Real)
- (-> (X* Real n) Real)))
- (define (permissive-function-type n)
- (-> (X* Any n) Real))
- ;;; Some useful types
- (define* (Lagrangian #:optional n) ;n = #degrees-of-freedom
- (if (default-object? n)
- (-> (UP* Real (UP* Real) (UP* Real)) Real)
- (-> (UP Real (UP* Real n) (UP* Real n)) Real)))
- (define* (Hamiltonian #:optional n) ;n = #degrees-of-freedom
- (if (default-object? n)
- (-> (UP Real (UP* Real) (DOWN* Real)) Real)
- (-> (UP Real (UP* Real n) (DOWN* Real n)) Real)))
- #| ;;; For example
- (define L (literal-function 'L (Lagrangian)))
- (pe (L (->L-state 't 'x 'v)))
- (L (up t x v))
- (pe ((D L) (->L-state 't 'x 'v)))
- (down (((partial 0) L) (up t x v))
- (((partial 1) L) (up t x v))
- (((partial 2) L) (up t x v)))
- (pe (L (->L-state 't (up 'x 'y) (up 'v_x 'v_y))))
- (L (up t (up x y) (up v_x v_y)))
- (pe ((D L) (->L-state 't (up 'x 'y) (up 'v_x 'v_y))))
- (down
- (((partial 0) L) (up t (up x y) (up v_x v_y)))
- (down (((partial 1 0) L) (up t (up x y) (up v_x v_y)))
- (((partial 1 1) L) (up t (up x y) (up v_x v_y))))
- (down (((partial 2 0) L) (up t (up x y) (up v_x v_y)))
- (((partial 2 1) L) (up t (up x y) (up v_x v_y)))))
- (define H (literal-function 'H (Hamiltonian)))
- (pe (H (->H-state 't 'x 'p)))
- (H (up t x p))
- (pe ((D H) (->H-state 't 'x 'p)))
- (down (((partial 0) H) (up t x p))
- (((partial 1) H) (up t x p))
- (((partial 2) H) (up t x p)))
- (pe (H (->H-state 't (up 'x 'y) (down 'p_x 'p_y))))
- (H (up t (up x y) (down p_x p_y)))
- (pe ((D H) (->H-state 't (up 'x 'y) (down 'p_x 'p_y))))
- (down
- (((partial 0) H) (up t (up x y) (down p_x p_y)))
- (down (((partial 1 0) H) (up t (up x y) (down p_x p_y)))
- (((partial 1 1) H) (up t (up x y) (down p_x p_y))))
- (up (((partial 2 0) H) (up t (up x y) (down p_x p_y)))
- (((partial 2 1) H) (up t (up x y) (down p_x p_y)))))
- |#
- ;;;---------------------------------------------------------------------
- (define (type->domain type)
- (assert (eq? (car type) '->))
- (cadr type))
- (define (type->range-type type)
- (assert (eq? (car type) '->))
- (caddr type))
- (define (type->domain-types type)
- (assert (eq? (car type) '->))
- (let ((domain (type->domain type)))
- (cond ((and (pair? domain) (eq? (car domain) 'X))
- (cdr domain))
- (else
- (list domain)))))
- (define (type->arity type)
- (assert (eq? (car type) '->))
- (let ((domain (type->domain type)))
- (cond ((and (pair? domain) (eq? (car domain) 'X))
- (length->exact-arity (length (cdr domain))))
- ((and (pair? domain) (eq? (car domain) 'X*))
- *at-least-zero*)
- (else
- (length->exact-arity 1)))))
- (define (length->exact-arity n)
- (assert (exact-integer? n))
- (cons n n))
- (define (type-expression->predicate type-expression)
- (cond ((pair? type-expression)
- (case (car type-expression)
- ((X)
- (let ((type-predicates
- (map type-expression->predicate
- (cdr type-expression))))
- (lambda (datum)
- (and (vector? datum)
- (all-satisfied type-predicates datum)))))
- ((UP)
- (let ((type-predicates
- (map type-expression->predicate
- (cdr type-expression))))
- (lambda (datum)
- (and (up? datum)
- (all-satisfied type-predicates datum)))))
- ((DOWN)
- (let ((type-predicates
- (map type-expression->predicate
- (cdr type-expression))))
- (lambda (datum)
- (and (down? datum)
- (all-satisfied type-predicates datum)))))
- ((X*)
- (let ((type-predicates
- (map type-expression->predicate
- (cdr type-expression))))
- (lambda (datum)
- (cond ((vector? datum)
- (let ((n (vector-length datum)))
- (let lp ((i 0) (preds type-predicates))
- (cond ((fix:= i n) #t)
- (((car preds) (vector-ref datum i))
- (lp (fix:+ i 1)
- (if (null? (cdr preds))
- preds
- (cdr preds))))
- (else #f)))))
- ((null? (cdr type-predicates))
- ((car type-predicates) datum))
- (else #f)))))
- ((UP* DOWN*)
- (let ((type-predicates
- (map type-expression->predicate
- (cdr type-expression)))
- (test?
- (if (eq? (car type-expression) 'UP*) up? down?)))
- (lambda (datum)
- (cond ((test? datum)
- (let ((n (s:length datum)))
- (let lp ((i 0) (preds type-predicates))
- (cond ((fix:= i n) #t)
- (((car preds) (s:ref datum i))
- (lp (fix:+ i 1)
- (if (null? (cdr preds))
- preds
- (cdr preds))))
- (else #f)))))
- ((and (not (structure? datum))
- (null? (cdr type-predicates)))
- ((car type-predicates) datum))
- (else #f)))))
- ((->) function?)
- (else (error "Unknown type combinator" type-expression))))
- ((eq? type-expression Real) numerical-quantity?)
- ((eq? type-expression Any) any?)
- (else (error "Unknown primitive type" type-expression))))
- (define (all-satisfied type-preds structure)
- (let ((n (length type-preds)))
- (and (fix:= n (s:length structure))
- (let lp ((types type-preds) (i 0))
- (cond ((fix:= i n) #t)
- (((car types) (s:ref structure i))
- (lp (cdr types) (fix:+ i 1)))
- (else #f))))))
- (define (type-expression->type-tag type-expression)
- (let ((type
- (cond ((pair? type-expression)
- (case (car type-expression)
- ((X) *vector*)
- ((UP) *up*)
- ((DOWN) *down*)
- ((X*) *vector*)
- ((UP*) *up*)
- ((DOWN*) *down*)
- ((->) *function*)
- (else
- (error "Unknown type combinator" type-expression))))
- ((eq? type-expression Real)
- *number*)
- (else
- (error "Unknown primitive type" type-expression)))))
- (abstract-type-tag type)))
- ;;; For computing the type of the range of the derivative of a
- ;;; function with a given type.
- (define (df-range-type f-domain-types f-range-type arg)
- ;; There is some idea here that I should do something like
- ;; (type-complement (type-expression arg) f-range-type)
- ;; but the argument currently escapes me as to why I need this.
- f-range-type)
- ;;; Functions with types are defined as apply hooks...
- (define (f:domain-types f)
- (if (typed-or-abstract-function? f)
- (cadr (apply-hook-extra f))
- #f))
- (define (f:range-type f)
- (if (typed-or-abstract-function? f)
- (caddr (apply-hook-extra f))
- #f))
- ;;; FBE: make it a parameter
- ;; (define *literal-reconstruction* #f)
- (define *literal-reconstruction* (make-parameter #f))
- (define (f:expression f)
- (if (typed-or-abstract-function? f)
- (if (*literal-reconstruction*)
- (cadddr (cdr (apply-hook-extra f)))
- (cadddr (apply-hook-extra f)))
- #f))
- (define (typed-function function range-type domain-types)
- (let ((arity (g:arity function)))
- (assert (exactly-n? arity)
- "I cannot handle this arity -- TYPED-FUNCTION")
- (assert (fix:= (length domain-types) (car arity))
- "Inconsistent arity -- TYPED-FUNCTION")
- (let ((apply-hook (make-apply-hook #f #f)))
- (set-apply-hook-procedure! apply-hook function)
- (set-apply-hook-extra! apply-hook
- (list '*function* domain-types range-type #f))
- apply-hook)))
- (define (literal-function? f)
- (and (apply-hook? f)
- (eq? (car (apply-hook-extra f)) '*function*)))
- (define* (literal-function fexp #:optional descriptor)
- (if (default-object? descriptor)
- (set! descriptor (default-function-type 1)))
- (let ((arity (type->arity descriptor))
- (range-type (type->range-type descriptor)))
- (cond ((or (eq? Real range-type)
- (eq? '*function* (type-expression->type-tag range-type)))
- (litfun fexp arity range-type (type->domain-types descriptor)
- `(literal-function ',fexp ,descriptor)))
- ((not (symbol? fexp))
- (error "Cannot handle this function expression: LITERAL-FUNCTION"
- fexp
- descriptor))
- ((eq? (car range-type) 'UP)
- (let ((n (length (cdr range-type))))
- (s:generate n 'up
- (lambda (i)
- (literal-function (symbol fexp '^ i)
- (-> (type->domain descriptor)
- (list-ref (cdr range-type) i)))))))
- ((eq? (car range-type) 'DOWN)
- (let ((n (length (cdr range-type))))
- (s:generate n 'down
- (lambda (i)
- (literal-function (symbol fexp '_ i)
- (-> (type->domain descriptor)
- (list-ref (cdr range-type) i)))))))
- (else
- (error "Cannot handle this range type: LITERAL-FUNCTION"
- fexp
- descriptor)))))
- (define (litfun fexp arity range-type domain-types call)
- ;;(assert (exactly-n? arity)
- ;; "I cannot handle this arity -- LITERAL-FUNCTION")
- (let ((apply-hook (make-apply-hook #f #f)))
- (let ((litf
- (cond ((equal? arity *exactly-zero*)
- (lambda () (literal-apply apply-hook '())))
- ((equal? arity *exactly-one*)
- (lambda (x) (literal-apply apply-hook (list x))))
- ((equal? arity *exactly-two*)
- (lambda (x y) (literal-apply apply-hook (list x y))))
- ((equal? arity *exactly-three*)
- (lambda (x y z) (literal-apply apply-hook (list x y z))))
- (else
- (lambda args (literal-apply apply-hook args))))))
- (set-apply-hook-procedure! apply-hook litf)
- (set-apply-hook-extra! apply-hook
- (list '*function* domain-types range-type fexp call))
- apply-hook)))
- (define (literal-apply apply-hook args)
- (if (rexists differential? args)
- (litderiv apply-hook args)
- (let ((fexp (f:expression apply-hook))
- (dtypes (f:domain-types apply-hook))
- (rtype (f:range-type apply-hook)))
- (let ((dpreds (map type-expression->predicate dtypes))
- (range-tag (type-expression->type-tag rtype)))
- (assert (&and (map (lambda (p x) (p x)) dpreds args))
- "Wrong type argument -- LITERAL-FUNCTION"
- (cons fexp args))
- (if (eq? range-tag '*function*)
- (let ((ans (literal-function `(,fexp ,@args) rtype)))
- ;; properties?
- ans)
- (let ((ans (make-combination range-tag fexp args)))
- (add-property! ans 'literal-function apply-hook)
- (add-property! ans 'type-expression rtype)
- ans))))))
- (define (litderiv apply-hook args)
- (let ((v (list->up-structure args)))
- (let ((maxtag (apply max-order-tag (s:fringe v))))
- (let ((ev
- (up-structure->list
- (s:map/r (lambda (x) (without-tag x maxtag)) v)))
- (dv
- (s:map/r (lambda (x) (with-tag x maxtag)) v)))
- (d:+ (apply apply-hook ev)
- (a-reduce d:+
- (map (lambda (partialx dx)
- (d:* (apply partialx ev) dx))
- (s:fringe (make-partials apply-hook v))
- (s:fringe dv))))))))
- (define (make-partials apply-hook v)
- (define (fd indices vv)
- (cond ((structure? vv)
- (s:generate (s:length vv) (s:same vv)
- (lambda (i)
- (fd (cons i indices)
- (s:ref vv i)))))
- ((or (numerical-quantity? vv)
- (abstract-quantity? vv))
- (let ((fexp
- (let ((is (reverse indices)))
- (if (equal? (g:arity apply-hook) *exactly-one*) ;univariate
- (if (fix:= (car is) 0)
- (if (fix:= (length indices) 1)
- (symb:derivative (f:expression apply-hook))
- `((partial ,@(cdr is))
- ,(f:expression apply-hook)))
- (error "Wrong indices -- MAKE-PARTIALS"
- indices vv))
- `((partial ,@is)
- ,(f:expression apply-hook)))))
- (range
- (df-range-type (f:domain-types apply-hook)
- (f:range-type apply-hook)
- vv))
- (domain
- (f:domain-types apply-hook)))
- (litfun fexp
- (g:arity apply-hook)
- range
- domain
- `(literal-function ',fexp
- (-> ,(apply X domain) ,range)))))
- (else
- (error "Bad structure -- MAKE-PARTIALS"
- indices vv))))
- (fd '() v))
- #|
- ;;; Not used anywhere.
- (define (accumulate-tags v)
- (cond ((structure? v)
- (let ((n (s:length v)))
- (let lp ((i 0) (ut '()))
- (if (fix:= i n)
- ut
- (lp (fix:+ i 1)
- (union-differential-tags
- ut
- (accumulate-tags (s:ref v i))))))))
- ((numerical-quantity? v)
- (differential-tags
- (car (last-pair (differential->terms v)))))
- (else
- (error "Bad structure -- ACCUMULATE-TAGS" v))))
- |#
|