setup/unpack addition and docs
svn: r9370
This commit is contained in:
Matthew Flatt
parent
2736de7404
commit
99943314d2
|
|
@ -46,6 +46,11 @@
|
|||
;; from (define-for-syntax x ...). This isn't a problem in practice,
|
||||
;; because no one uses the same name for different-phase exported
|
||||
;; bindings.
|
||||
;;
|
||||
;; However, we assume that bidings are defined as originating from some
|
||||
;; module at phase 0. Maybe it's defined at phase 1 and re-exported
|
||||
;; later for phase 0 (after a require-for-template), in which case the
|
||||
;; re-exporting module is the one we find.
|
||||
(let ([b (cond
|
||||
[(identifier? stx/binding)
|
||||
(identifier-binding stx/binding phase-level)]
|
||||
|
|
@ -90,7 +95,7 @@
|
|||
[export-phase (list-ref (car queue) 4)]
|
||||
[queue (cdr queue)])
|
||||
(let* ([rmp (module-path-index-resolve mod)]
|
||||
[eb (and (equal? defn-phase export-phase)
|
||||
[eb (and (equal? 0 export-phase) ;; look for the phase-0 export; good idea?
|
||||
(list (let ([p (resolved-module-path-name rmp)])
|
||||
(if (path? p)
|
||||
(intern-taglet (path->main-collects-relative p))
|
||||
|
|
|
|||
|
|
@ -15,6 +15,7 @@
|
|||
setup/plt-installer-sig
|
||||
setup/plt-installer-unit
|
||||
setup/pack
|
||||
setup/unpack
|
||||
compiler/compiler
|
||||
launcher/launcher
|
||||
compiler/sig
|
||||
|
|
@ -84,7 +85,7 @@ The @|setup-plt| executable performs two main services:
|
|||
should be a function like @scheme[compile]; see the
|
||||
@filepath{errortrace} collection for an example.}
|
||||
|
||||
@item{@bold{Unpacking single @filepath{.plt} files:} A
|
||||
@item{@bold{Unpacking @filepath{.plt} files:} A
|
||||
@filepath{.plt} file is a platform-independent distribution archive
|
||||
for software based on PLT Scheme. When one or more file names are
|
||||
provided as the command line arguments to @|setup-plt|, the files
|
||||
|
|
@ -325,37 +326,7 @@ Optional @filepath{info.ss} fields trigger additional actions by
|
|||
|
||||
@section[#:tag "setup-plt-plt"]{Running @|setup-plt| from Scheme}
|
||||
|
||||
@; ----------------------------------------
|
||||
|
||||
@subsection{Installing a Single @filepath{.plt} File}
|
||||
|
||||
@local-module[setup/plt-single-installer]{
|
||||
|
||||
@defmodule[setup/plt-single-installer]{
|
||||
The @schememodname{setup/plt-single-installer} module provides a function for
|
||||
installing a single @filepath{.plt} file:}
|
||||
|
||||
@defproc[(run-single-installer
|
||||
(file path-string?)
|
||||
(get-dir-proc (-> (or/c path-string? false/c)))) void?]{
|
||||
Creates a separate thread and namespace, runs the installer in that
|
||||
thread with the new namespace, and returns when the thread
|
||||
completes or dies. It also creates a custodian
|
||||
(see @secref[#:doc ref-src]{custodians}) to manage the
|
||||
created thread, sets the exit handler for the thread to shut down
|
||||
the custodian, and explicitly shuts down the custodian
|
||||
when the created thread terminates or dies.
|
||||
|
||||
The @scheme[get-dir-proc] procedure is called if the installer needs a
|
||||
target directory for installation, and a @scheme[#f] result means that
|
||||
the user canceled the installation. Typically, @scheme[get-dir-proc] is
|
||||
@scheme[current-directory].}}
|
||||
|
||||
@; ----------------------------------------
|
||||
|
||||
@subsection[#:tag "setup-plt-unit"]{General Case}
|
||||
|
||||
The @scheme[setup/setup-unit] library provides @|setup-plt| in unit
|
||||
The @schememodname[setup/setup-unit] library provides @|setup-plt| in unit
|
||||
form. The associated @scheme[setup/option-sig] and
|
||||
@scheme[setup/option-unit] libraries provides the interface for
|
||||
setting options for the run of @|setup-plt|.
|
||||
|
|
@ -396,7 +367,7 @@ and exports nothing. Invoking @scheme[setup@] starts the setup process.}
|
|||
|
||||
@; ----------------------------------------
|
||||
|
||||
@subsubsection{Options Unit}
|
||||
@subsection{Options Unit}
|
||||
|
||||
@defmodule[setup/option-unit]
|
||||
|
||||
|
|
@ -406,7 +377,7 @@ Imports nothing and exports @scheme[setup-option^].}
|
|||
|
||||
@; ----------------------------------------
|
||||
|
||||
@subsubsection{Options Signature}
|
||||
@subsection{Options Signature}
|
||||
|
||||
@defmodule[setup/option-sig]
|
||||
|
||||
|
|
@ -677,9 +648,38 @@ for making @filepath{.plt} archives:}
|
|||
@scheme[file-mode] argument specifies the default mode for packing a file,
|
||||
either @scheme['file] or @scheme['file-replace].}
|
||||
|
||||
@; ------------------------------------------------------------------------
|
||||
@; ----------------------------------------
|
||||
|
||||
@subsection[#:tag "unpacking-.plt-archives"]{Unpacking @filepath{.plt} Archives}
|
||||
@subsection{Installing a Single @filepath{.plt} File}
|
||||
|
||||
The @schememodname[setup/plt-single-installer] module provides a
|
||||
function for installing a single @filepath{.plt} file, and
|
||||
@schememodname[setup/plt-single-installer] wraps it with a GUI
|
||||
interface.
|
||||
|
||||
@subsubsection{Non-GUI Installer}
|
||||
|
||||
@local-module[setup/plt-single-installer]{
|
||||
|
||||
@defmodule[setup/plt-single-installer]
|
||||
|
||||
@defproc[(run-single-installer
|
||||
(file path-string?)
|
||||
(get-dir-proc (-> (or/c path-string? false/c)))) void?]{
|
||||
Creates a separate thread and namespace, runs the installer in that
|
||||
thread with the new namespace, and returns when the thread
|
||||
completes or dies. It also creates a custodian
|
||||
(see @secref[#:doc ref-src]{custodians}) to manage the
|
||||
created thread, sets the exit handler for the thread to shut down
|
||||
the custodian, and explicitly shuts down the custodian
|
||||
when the created thread terminates or dies.
|
||||
|
||||
The @scheme[get-dir-proc] procedure is called if the installer needs a
|
||||
target directory for installation, and a @scheme[#f] result means that
|
||||
the user canceled the installation. Typically, @scheme[get-dir-proc] is
|
||||
@scheme[current-directory].}}
|
||||
|
||||
@subsubsection[#:tag "gui-unpacking"]{GUI Installer}
|
||||
|
||||
@defmodule[setup/plt-installer]{ The
|
||||
@schememodname{setup/plt-installer} library in the setup collection
|
||||
|
|
@ -698,7 +698,8 @@ for making @filepath{.plt} archives:}
|
|||
A thunk that is run after a @filepath{.plt} file is installed.}
|
||||
|
||||
@defproc[(with-installer-window
|
||||
(do-install ((or/c (is-a?/c dialog%) (is-a?/c frame%)) . -> . void?))
|
||||
(do-install ((or/c (is-a?/c dialog%) (is-a?/c frame%))
|
||||
. -> . void?))
|
||||
(cleanup-thunk (-> any)))
|
||||
void?]{
|
||||
Creates a frame, sets up the current error and output ports, and
|
||||
|
|
@ -715,14 +716,18 @@ for making @filepath{.plt} archives:}
|
|||
void?]{
|
||||
The same as the sole export of @schememodname[setup/plt-single-installer], but with a GUI.}
|
||||
|
||||
@subsubsection{Unpacking Signature}
|
||||
@; ----------------------------------------
|
||||
|
||||
@subsubsection{GUI Unpacking Signature}
|
||||
|
||||
@defmodule[setup/plt-installer-sig]{
|
||||
@defsignature[setup:plt-installer^ ()]{
|
||||
Provides two names: @scheme[run-installer] and @scheme[on-installer-run].}
|
||||
}
|
||||
|
||||
@subsubsection{Unpacking Unit}
|
||||
@; ----------------------------------------
|
||||
|
||||
@subsubsection{GUI Unpacking Unit}
|
||||
|
||||
@defmodule[setup/plt-installer-unit]{
|
||||
|
||||
|
|
@ -730,6 +735,98 @@ Imports @scheme[mred^] and exports @scheme[setup:plt-installer^]. }
|
|||
|
||||
@; ------------------------------------------------------------------------
|
||||
|
||||
@subsection[#:tag "unpacking-.plt-archives"]{Unpacking @filepath{.plt} Archives}
|
||||
|
||||
@defmodule[setup/unpack]{The @schememodname[setup/unpack]
|
||||
library provides raw support for unpacking a @filepath{.plt} file.}
|
||||
|
||||
@defproc[(unpack [archive path-string?]
|
||||
[main-collects-parent-dir path-string? (current-directory)]
|
||||
[print-status (string? . -> . any) (lambda (x) (printf "~a\n" x))]
|
||||
[get-target-directory (-> path-string?) (lambda () (current-directory))]
|
||||
[force? any/c #f]
|
||||
[get-target-plt-directory
|
||||
(path-string?
|
||||
path-string?
|
||||
(listof path-string?)
|
||||
. -> . path-string?)
|
||||
(lambda (_preferred-dir _main-dir _options)
|
||||
_preferred-dir)])
|
||||
void?]{
|
||||
|
||||
Unpacks @scheme[archive].
|
||||
|
||||
The @scheme[main-collects-parent-dir] argument is passed along to
|
||||
@scheme[get-target-plt-directory].
|
||||
|
||||
The @scheme[print-status] argument is used to report unpacking
|
||||
progress.
|
||||
|
||||
The @scheme[get-target-directory] argument is used to get the
|
||||
destination directory for unpacking an archive whose content is
|
||||
relative to an arbitrary directory.
|
||||
|
||||
If @scheme[force?] is true, then version and required-collection
|
||||
mismatches (comparing information in the archive to the current
|
||||
installation) are ignored.
|
||||
|
||||
The @scheme[get-target-plt-directory] function is called to select a
|
||||
target for installation for an archive whose is relative to the
|
||||
installation. The function should normally return one if its first two
|
||||
arguments; the third argument merely contains the first two, but has
|
||||
only one element if the first two are the same. If the archive does
|
||||
not request installation for all uses, then the first two arguments
|
||||
will be different, and the former will be a user-specific location,
|
||||
while the second will refer to the main installation.}
|
||||
|
||||
@defproc[(fold-plt-archive [archive path-string?]
|
||||
[on-config-fn (any/c any/c . -> . any/c)]
|
||||
[on-setup-unit (any/c input-port? any/c . -> . any/c)]
|
||||
[on-directory (path-string? any/c . -> . any/c)]
|
||||
[on-file (path-string? input-port? any/c . -> . any/c)]
|
||||
[initial-value any/c])
|
||||
any/c]{
|
||||
|
||||
Traverses the content of @scheme[archive], which must be a
|
||||
@filepath{.plt} archive that is created with the default unpacking
|
||||
unit and configuration expression. The configuration expression is not
|
||||
evaluated, the unpacking unit is not invoked, and not files are
|
||||
unpacked to the filesystem. Instead, the information in the archive is
|
||||
reported back through @scheme[on-config], @scheme[on-setup-unit],
|
||||
@scheme[on-directory], and @scheme[on-file], each of which can build on
|
||||
an accumulated value that starts with @scheme[initial-value] and whose
|
||||
final value is returned.
|
||||
|
||||
The @scheme[on-config-fn] function is called once with an S-expression
|
||||
that represents a function to implement configuration information.
|
||||
The second argument to @scheme[on-config] is @scheme[initial-value],
|
||||
and the function's result is passes on as the last argument to @scheme[on-setup-unit].
|
||||
|
||||
The @scheme[on-setup-unit] function is called with the S-expression
|
||||
representation of the installation unit, an input port that points to
|
||||
the rest of the file, and the accumulated value. This input port is
|
||||
the same port that will be used in the rest of processing, so if
|
||||
@scheme[on-setup-unit] consumes any data from the port, then that data
|
||||
will not be consumed by the remaining functions. (This means that
|
||||
on-setup-unit can leave processing in an inconsistent state, which is
|
||||
not checked by anything, and therefore could cause an error.)
|
||||
The result of @scheme[on-setup-unit] becomes the new accumulated value.
|
||||
|
||||
For each directory that would be created by the archive when unpacking
|
||||
normally, @scheme[on-directory] is called with the directory path and the
|
||||
accumulated value up to that point, and its result is the new
|
||||
accumulated value.
|
||||
|
||||
For each file that would be created by the archive when unpacking
|
||||
normally, @scheme[on-file] is called with the file path, an input port
|
||||
containing the contents of the file, and the accumulated value up to
|
||||
that point; its result is the new accumulated value. The input port
|
||||
can be used or ignored, and parsing of the rest of the file continues
|
||||
the same either way. After @scheme[on-file] returns control, however,
|
||||
the input port is drained of its content.}
|
||||
|
||||
@; ------------------------------------------------------------------------
|
||||
|
||||
@subsection[#:tag "format-of-.plt-archives"]{
|
||||
Format of @filepath{.plt} Archives}
|
||||
|
||||
|
|
@ -1022,8 +1119,8 @@ An @deftech{unpackable} is one of the following:
|
|||
collections and installed @|PLaneT| packages) whose
|
||||
@filepath{info.ss} file defines one or more of the given
|
||||
symbols. The result is based on a cache that is computed by
|
||||
@|setup-plt| and stored in the @filepath{info-domain} sub-directory
|
||||
of each collection directory (as determined by the
|
||||
@|setup-plt| and stored in the @indexed-file{info-domain}
|
||||
sub-directory of each collection directory (as determined by the
|
||||
@envvar{PLT_COLLECTION_PATHS} environment variable, etc.) and the
|
||||
file @filepath{cache.ss} in the user add-on directory.
|
||||
|
||||
|
|
@ -1101,3 +1198,7 @@ than specified in the contract above, it is returned as-is.}
|
|||
|
||||
Like @scheme[load-xref], but automatically find all cross-reference files for
|
||||
manuals that have been installed with @exec{setup-plt}.}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
||||
@index-section[]
|
||||
|
|
|
|||
|
|
@ -5,10 +5,16 @@
|
|||
mzlib/inflate
|
||||
mzlib/file
|
||||
mzlib/list
|
||||
mzlib/port
|
||||
net/base64
|
||||
(lib "getinfo.ss" "setup")
|
||||
"dirs.ss")
|
||||
|
||||
(provide unpack
|
||||
fold-plt-archive)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; Returns a port and a kill thunk
|
||||
(define (port64gz->port p64gz)
|
||||
;; Inflate in a thread so the whole input isn't read at once
|
||||
|
|
@ -27,6 +33,126 @@
|
|||
(lambda () (gunzip-through-ports base64-out guz-in))
|
||||
(lambda () (close-output-port guz-in)))))])
|
||||
(values guz-out (lambda () (kill-thread 64t) (kill-thread gzt))))))
|
||||
|
||||
;; ------------------------------------------------------------
|
||||
|
||||
;; fold-plt-archive : path[to .plt file] (sexpr A -> A) (sexpr input-port A -> A) (path A -> A) (path input-port A -> A) A -> A
|
||||
(define (fold-plt-archive filename on-config-fn on-setup-unit on-directory on-file initial-value)
|
||||
(let*-values ([(fip) (open-input-file filename)]
|
||||
[(ip kill) (port64gz->port fip)])
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ () (fold-plt-archive-port ip on-config-fn on-setup-unit on-directory on-file initial-value))
|
||||
(λ ()
|
||||
(close-input-port fip)
|
||||
(kill)))))
|
||||
|
||||
;; fold-plt-archive-port : input-port (sexpr A -> A) (sexpr input-port A -> A) (path A -> A) (path input-port A -> A) A -> A
|
||||
(define (fold-plt-archive-port p on-config-fn on-setup-unit on-directory on-file initial-value)
|
||||
|
||||
;; skip past the initial #"PLT" and two sexprs
|
||||
(unless (and (eq? #\P (read-char p))
|
||||
(eq? #\L (read-char p))
|
||||
(eq? #\T (read-char p)))
|
||||
(error "not an unpackable distribution archive"))
|
||||
|
||||
(let* ([config-fn-sexpr (read p)]
|
||||
[_ (when (eof-object? config-fn-sexpr) (error "malformed input"))]
|
||||
[val (on-config-fn config-fn-sexpr initial-value)]
|
||||
|
||||
[setup-unit (read p)]
|
||||
[_ (when (eof-object? setup-unit) (error "malformed input"))]
|
||||
[val (on-setup-unit setup-unit p val)])
|
||||
|
||||
;; read contents of file directly. [on-setup-unit may have consumed all input,
|
||||
;; but if so this loop will just do nothing.]
|
||||
(let loop ([val val])
|
||||
(let ([kind (read p)])
|
||||
(cond
|
||||
[(eof-object? kind) val]
|
||||
[else
|
||||
(case kind
|
||||
[(dir)
|
||||
(let* ([v (read p)]
|
||||
[s (expr->path-descriptor v)])
|
||||
(unless (relative-path-descriptor? s)
|
||||
(error "expected a directory name relative path string, got" s))
|
||||
(let ([next-val (on-directory s val)])
|
||||
(loop next-val)))]
|
||||
[(file file-replace)
|
||||
(let* ([v (read p)]
|
||||
[s (expr->path-descriptor v)])
|
||||
(unless (relative-path-descriptor? s)
|
||||
(error "expected a file name relative path string, got" s))
|
||||
(let ([len (read p)])
|
||||
(unless (and (number? len) (integer? len))
|
||||
(error "expected a file name size, got" len))
|
||||
;; Find starting *
|
||||
(let loop ()
|
||||
(let ([c (read-char p)])
|
||||
(cond [(char=? c #\*) (void)] ; found it
|
||||
[(char-whitespace? c) (loop)]
|
||||
[(eof-object? c) (void)] ; signal the error below
|
||||
[else (error
|
||||
(format "unexpected character setting up ~a, looking for *" s)
|
||||
c)])))
|
||||
(let-values ([(control fp) (protected-limited-input-port p len)])
|
||||
(let ([next-val (on-file s fp val)])
|
||||
(exhaust-port control)
|
||||
(loop next-val)))))]
|
||||
[else (error "unknown file tag" kind)])])))))
|
||||
|
||||
;; path-descriptor ::= 'same | (list location path)
|
||||
;; location ::= symbol in '(same collects doc lib include)
|
||||
|
||||
;; expr->path-descriptor : sexpr -> path-descriptor
|
||||
;; extracts a path-descriptor from an sexpr embedded in a .plt file
|
||||
;; raises an error if the given sexpr can't be converted to a path descriptor
|
||||
(define (expr->path-descriptor v)
|
||||
(cond
|
||||
[(null? v) 'same]
|
||||
[(and (pair? v) (symbol? (car v)) (symbol=? (car v) 'same))
|
||||
'same]
|
||||
[(and (pair? v) (string? (car v)))
|
||||
(let ([location (string->loc (car v))])
|
||||
(list location (apply build-path (cdr v))))]
|
||||
[else (error "malformed path description: " v)]))
|
||||
|
||||
;; string->loc : string -> location
|
||||
;; converts the string into a corresponding location, or raises an error
|
||||
;; if that is not possible
|
||||
(define (string->loc str)
|
||||
(let ([loc (string->symbol str)])
|
||||
(cond
|
||||
[(memq loc '(collects doc lib include same)) loc]
|
||||
[else (error "unknown path root: " loc)])))
|
||||
|
||||
;; relative-path-descriptor? : path-descriptor -> boolean
|
||||
;; determines if the given path descriptor names a relative file rather
|
||||
;; than an absolute one
|
||||
(define (relative-path-descriptor? s)
|
||||
(or (eq? s 'same) (relative-path? (cadr s))))
|
||||
|
||||
;; protected-limited-output-port input-port n -> (values input-port input-port)
|
||||
;; returns two input ports. the first reads from the given input port, and the second
|
||||
;; reads from the first.
|
||||
;; why would you ever want to do this? So that you can hand out the second, and then
|
||||
;; regardless of whether the user closes it or not you still have a limited input port
|
||||
;; you can read to exhaustion.
|
||||
(define (protected-limited-input-port ip limit)
|
||||
(let* ([i2 (make-limited-input-port ip limit #f)]
|
||||
[i3 (make-limited-input-port i2 limit #f)])
|
||||
(values i2 i3)))
|
||||
|
||||
;; exhaust-port : input-port -> void
|
||||
;; consumes all input on the given port
|
||||
(define exhaust-port
|
||||
(let ([nowhere (open-output-nowhere)])
|
||||
(λ (ip) (copy-port ip nowhere))))
|
||||
|
||||
|
||||
;; ------------------------------------------------------------
|
||||
|
||||
|
||||
(define (pretty-name f)
|
||||
(with-handlers ([void (lambda (x) f)])
|
||||
|
|
@ -298,6 +424,4 @@
|
|||
|
||||
;; Cancelled: no collections
|
||||
null))))
|
||||
(lambda () (kill) (close-input-port p64gz))))))
|
||||
|
||||
(provide unpack))
|
||||
(lambda () (kill) (close-input-port p64gz)))))))
|
||||
|
|
|
|||
|
|
@ -1,13 +1,12 @@
|
|||
(module ackermann mzscheme
|
||||
(define (ack m n)
|
||||
(cond ((zero? m) (+ n 1))
|
||||
((zero? n) (ack (- m 1) 1))
|
||||
(else (ack (- m 1) (ack m (- n 1))))))
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
|
||||
(define (main args)
|
||||
(let ((n (if (= (vector-length args) 0)
|
||||
1
|
||||
(string->number (vector-ref args 0)))))
|
||||
(printf "Ack(3,~a): ~a~n" n (ack 3 n))))
|
||||
(define (ack m n)
|
||||
(cond ((zero? m) (+ n 1))
|
||||
((zero? n) (ack (- m 1) 1))
|
||||
(else (ack (- m 1) (ack m (- n 1))))))
|
||||
|
||||
(main (current-command-line-arguments)))
|
||||
(command-line #:args (n)
|
||||
(printf "Ack(3,~a): ~a~n"
|
||||
n
|
||||
(ack 3 (string->number n))))
|
||||
|
|
|
|||
|
|
@ -1,49 +1,50 @@
|
|||
;;; The Great Computer Language Shootout
|
||||
;;; http://shootout.alioth.debian.org/
|
||||
;;; Derived from the Chicken variant by Sven Hartrumpf
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
|
||||
(module binarytrees mzscheme
|
||||
(define-struct node (left val right))
|
||||
|
||||
(define-struct node (left val right))
|
||||
;; Instead of (define-struct leaf (val)):
|
||||
(define (make-leaf val) (make-node #f val #f))
|
||||
(define (leaf? l) (not (node-left l)))
|
||||
(define (leaf-val l) (node-val l))
|
||||
|
||||
;; Instead of (define-struct leaf (val)):
|
||||
(define (make-leaf val) (make-node #f val #f))
|
||||
(define (leaf? l) (not (node-left l)))
|
||||
(define (leaf-val l) (node-val l))
|
||||
(define (make item d)
|
||||
(if (= d 0)
|
||||
(make-leaf item)
|
||||
(let ((item2 (* item 2))
|
||||
(d2 (- d 1)))
|
||||
(make-node (make (- item2 1) d2) item (make item2 d2)))))
|
||||
|
||||
(define (make item d)
|
||||
(if (= d 0)
|
||||
(make-leaf item)
|
||||
(let ((item2 (* item 2))
|
||||
(d2 (- d 1)))
|
||||
(make-node (make (- item2 1) d2) item (make item2 d2)))))
|
||||
(define (check t)
|
||||
(if (leaf? t)
|
||||
(leaf-val t)
|
||||
(+ (node-val t) (- (check (node-left t)) (check (node-right t))))))
|
||||
|
||||
(define (check t)
|
||||
(if (leaf? t)
|
||||
(leaf-val t)
|
||||
(+ (node-val t) (- (check (node-left t)) (check (node-right t))))))
|
||||
(define (main n)
|
||||
(let* ((min-depth 4)
|
||||
(max-depth (max (+ min-depth 2) n)))
|
||||
(let ((stretch-depth (+ max-depth 1)))
|
||||
(printf "stretch tree of depth ~a\t check: ~a\n"
|
||||
stretch-depth
|
||||
(check (make 0 stretch-depth))))
|
||||
(let ((long-lived-tree (make 0 max-depth)))
|
||||
(do ((d 4 (+ d 2))
|
||||
(c 0 0))
|
||||
((> d max-depth))
|
||||
(let ((iterations (arithmetic-shift 1 (+ (- max-depth d) min-depth))))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((>= i iterations))
|
||||
(set! c (+ c (check (make i d)) (check (make (- i) d)))))
|
||||
(printf "~a\t trees of depth ~a\t check: ~a\n"
|
||||
(* 2 iterations)
|
||||
d
|
||||
c)))
|
||||
(printf "long lived tree of depth ~a\t check: ~a\n"
|
||||
max-depth
|
||||
(check long-lived-tree)))))
|
||||
|
||||
(define (main argv)
|
||||
(let* ((min-depth 4)
|
||||
(max-depth (max (+ min-depth 2) (string->number (vector-ref argv 0)))))
|
||||
(let ((stretch-depth (+ max-depth 1)))
|
||||
(printf "stretch tree of depth ~a\t check: ~a\n"
|
||||
stretch-depth
|
||||
(check (make 0 stretch-depth))))
|
||||
(let ((long-lived-tree (make 0 max-depth)))
|
||||
(do ((d 4 (+ d 2))
|
||||
(c 0 0))
|
||||
((> d max-depth))
|
||||
(let ((iterations (arithmetic-shift 1 (+ (- max-depth d) min-depth))))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((>= i iterations))
|
||||
(set! c (+ c (check (make i d)) (check (make (- i) d)))))
|
||||
(printf "~a\t trees of depth ~a\t check: ~a\n"
|
||||
(* 2 iterations)
|
||||
d
|
||||
c)))
|
||||
(printf "long lived tree of depth ~a\t check: ~a\n"
|
||||
max-depth
|
||||
(check long-lived-tree)))))
|
||||
|
||||
(main (current-command-line-arguments)))
|
||||
(command-line #:args (n)
|
||||
(main (string->number n)))
|
||||
|
|
|
|||
|
|
@ -1,55 +1,56 @@
|
|||
;;; The Great Computer Language Shootout
|
||||
;;; http://shootout.alioth.debian.org/
|
||||
|
||||
(module chameneos mzscheme
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
|
||||
(define (change c1 c2)
|
||||
(case c1
|
||||
[(red)
|
||||
(case c2 [(blue) 'yellow] [(yellow) 'blue] [else c1])]
|
||||
[(yellow)
|
||||
(case c2 [(blue) 'red] [(red) 'blue] [else c1])]
|
||||
[(blue)
|
||||
(case c2 [(yellow) 'red] [(red) 'yellow] [else c1])]))
|
||||
(define (change c1 c2)
|
||||
(case c1
|
||||
[(red)
|
||||
(case c2 [(blue) 'yellow] [(yellow) 'blue] [else c1])]
|
||||
[(yellow)
|
||||
(case c2 [(blue) 'red] [(red) 'blue] [else c1])]
|
||||
[(blue)
|
||||
(case c2 [(yellow) 'red] [(red) 'yellow] [else c1])]))
|
||||
|
||||
(define (place meeting-ch n)
|
||||
(thread
|
||||
(lambda ()
|
||||
(let loop ([n n])
|
||||
(if (zero? n)
|
||||
;; Fade all:
|
||||
(let loop ()
|
||||
(let ([c (channel-get meeting-ch)])
|
||||
(channel-put (car c) #f)
|
||||
(loop)))
|
||||
;; Let two meet:
|
||||
(let ([c1 (channel-get meeting-ch)]
|
||||
[c2 (channel-get meeting-ch)])
|
||||
(channel-put (car c1) (cdr c2))
|
||||
(channel-put (car c2) (cdr c1))
|
||||
(loop (sub1 n))))))))
|
||||
(define (place meeting-ch n)
|
||||
(thread
|
||||
(lambda ()
|
||||
(let loop ([n n])
|
||||
(if (zero? n)
|
||||
;; Fade all:
|
||||
(let loop ()
|
||||
(let ([c (channel-get meeting-ch)])
|
||||
(channel-put (car c) #f)
|
||||
(loop)))
|
||||
;; Let two meet:
|
||||
(let ([c1 (channel-get meeting-ch)]
|
||||
[c2 (channel-get meeting-ch)])
|
||||
(channel-put (car c1) (cdr c2))
|
||||
(channel-put (car c2) (cdr c1))
|
||||
(loop (sub1 n))))))))
|
||||
|
||||
(define (creature color meeting-ch result-ch)
|
||||
(thread
|
||||
(lambda ()
|
||||
(let ([ch (make-channel)])
|
||||
(let loop ([color color][met 0])
|
||||
(channel-put meeting-ch (cons ch color))
|
||||
(let ([other-color (channel-get ch)])
|
||||
(if other-color
|
||||
;; Meet:
|
||||
(loop (change color other-color) (add1 met))
|
||||
;; Done:
|
||||
(channel-put result-ch met))))))))
|
||||
(define (creature color meeting-ch result-ch)
|
||||
(thread
|
||||
(lambda ()
|
||||
(let ([ch (make-channel)])
|
||||
(let loop ([color color][met 0])
|
||||
(channel-put meeting-ch (cons ch color))
|
||||
(let ([other-color (channel-get ch)])
|
||||
(if other-color
|
||||
;; Meet:
|
||||
(loop (change color other-color) (add1 met))
|
||||
;; Done:
|
||||
(channel-put result-ch met))))))))
|
||||
|
||||
(let ([result-ch (make-channel)]
|
||||
[meeting-ch (make-channel)])
|
||||
(place meeting-ch (string->number (vector-ref (current-command-line-arguments) 0)))
|
||||
(creature 'blue meeting-ch result-ch)
|
||||
(creature 'red meeting-ch result-ch)
|
||||
(creature 'yellow meeting-ch result-ch)
|
||||
(creature 'blue meeting-ch result-ch)
|
||||
(printf "~a\n" (+ (channel-get result-ch)
|
||||
(channel-get result-ch)
|
||||
(channel-get result-ch)
|
||||
(channel-get result-ch)))))
|
||||
(let ([result-ch (make-channel)]
|
||||
[meeting-ch (make-channel)])
|
||||
(place meeting-ch (command-line #:args (n) (string->number n)))
|
||||
(creature 'blue meeting-ch result-ch)
|
||||
(creature 'red meeting-ch result-ch)
|
||||
(creature 'yellow meeting-ch result-ch)
|
||||
(creature 'blue meeting-ch result-ch)
|
||||
(printf "~a\n" (+ (channel-get result-ch)
|
||||
(channel-get result-ch)
|
||||
(channel-get result-ch)
|
||||
(channel-get result-ch))))
|
||||
|
|
|
|||
|
|
@ -1,24 +1,23 @@
|
|||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
|
||||
(module cheapconcurrency mzscheme
|
||||
(define (generate receive-ch n)
|
||||
(if (zero? n)
|
||||
receive-ch
|
||||
(let ([ch (make-channel)])
|
||||
(thread (lambda ()
|
||||
(let loop ()
|
||||
(channel-put ch (add1 (channel-get receive-ch)))
|
||||
(loop))))
|
||||
(generate ch (sub1 n)))))
|
||||
|
||||
(define (generate receive-ch n)
|
||||
(if (zero? n)
|
||||
receive-ch
|
||||
(let ([ch (make-channel)])
|
||||
(thread (lambda ()
|
||||
(let loop ()
|
||||
(channel-put ch (add1 (channel-get receive-ch)))
|
||||
(loop))))
|
||||
(generate ch (sub1 n)))))
|
||||
|
||||
(let ([n (string->number
|
||||
(vector-ref (current-command-line-arguments) 0))])
|
||||
(let* ([start-ch (make-channel)]
|
||||
[end-ch (generate start-ch 500)])
|
||||
(let loop ([n n][total 0])
|
||||
(if (zero? n)
|
||||
(printf "~a\n" total)
|
||||
(begin
|
||||
(channel-put start-ch 0)
|
||||
(loop (sub1 n)
|
||||
(+ total (channel-get end-ch)))))))))
|
||||
(let ([n (command-line #:args (n) (string->number n))])
|
||||
(let* ([start-ch (make-channel)]
|
||||
[end-ch (generate start-ch 500)])
|
||||
(let loop ([n n][total 0])
|
||||
(if (zero? n)
|
||||
(printf "~a\n" total)
|
||||
(begin
|
||||
(channel-put start-ch 0)
|
||||
(loop (sub1 n)
|
||||
(+ total (channel-get end-ch))))))))
|
||||
|
|
|
|||
|
|
@ -5,82 +5,77 @@
|
|||
;;
|
||||
;; Ever-so-slightly tweaked for MzScheme by Brent Fulgham
|
||||
|
||||
(module fannkuch mzscheme
|
||||
(define vector-for-each (lambda (pred v)
|
||||
(do ((i 0 (add1 i))
|
||||
(v-length (vector-length v)))
|
||||
((>= i v-length))
|
||||
(pred (vector-ref v i)))))
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
|
||||
(define (vector-reverse-slice! v i j)
|
||||
(do ((i i (add1 i))
|
||||
(define vector-for-each (lambda (pred v)
|
||||
(do ((i 0 (add1 i))
|
||||
(v-length (vector-length v)))
|
||||
((>= i v-length))
|
||||
(pred (vector-ref v i)))))
|
||||
|
||||
(define (vector-reverse-slice! v i j)
|
||||
(do ((i i (add1 i))
|
||||
(j (sub1 j) (sub1 j))) ; exclude position j
|
||||
((<= j i))
|
||||
(vector-swap! v i j)))
|
||||
|
||||
(define (vector-swap! v i j)
|
||||
(let ((t (vector-ref v i)))
|
||||
(vector-set! v i (vector-ref v j))
|
||||
(vector-set! v j t)))
|
||||
(define (vector-swap! v i j)
|
||||
(let ((t (vector-ref v i)))
|
||||
(vector-set! v i (vector-ref v j))
|
||||
(vector-set! v j t)))
|
||||
|
||||
(define (count-flips pi)
|
||||
(do ((rho (vector-copy pi))
|
||||
(i 0 (add1 i)))
|
||||
((= (vector-ref rho 0) 0) i)
|
||||
(vector-reverse-slice! rho 0 (add1 (vector-ref rho 0)))))
|
||||
(define (count-flips pi)
|
||||
(do ((rho (vector-copy pi))
|
||||
(i 0 (add1 i)))
|
||||
((= (vector-ref rho 0) 0) i)
|
||||
(vector-reverse-slice! rho 0 (add1 (vector-ref rho 0)))))
|
||||
|
||||
(define (vector-copy source)
|
||||
(do ((vec (make-vector (vector-length source)))
|
||||
(i 0 (add1 i)))
|
||||
((= i (vector-length source)) vec)
|
||||
(vector-set! vec i (vector-ref source i))))
|
||||
(define (vector-copy source)
|
||||
(let ([vec (make-vector (vector-length source))])
|
||||
(vector-copy! vec 0 source)
|
||||
vec))
|
||||
|
||||
(define (fannkuch n)
|
||||
(let ((pi (do ((pi (make-vector n))
|
||||
(i 0 (add1 i)))
|
||||
(define (fannkuch n)
|
||||
(let ((pi (do ((pi (make-vector n))
|
||||
(i 0 (add1 i)))
|
||||
((= i n) pi)
|
||||
(vector-set! pi i i)))
|
||||
(r n)
|
||||
(count (make-vector n)))
|
||||
(let loop ((flips 0)
|
||||
(perms 0))
|
||||
(cond ((< perms 30)
|
||||
(vector-for-each (lambda (x)
|
||||
(display (add1 x)))
|
||||
pi)
|
||||
(newline)))
|
||||
(do ()
|
||||
(vector-set! pi i i)))
|
||||
(r n)
|
||||
(count (make-vector n)))
|
||||
(let loop ((flips 0)
|
||||
(perms 0))
|
||||
(cond ((< perms 30)
|
||||
(vector-for-each (lambda (x)
|
||||
(display (add1 x)))
|
||||
pi)
|
||||
(newline)))
|
||||
(do ()
|
||||
((= r 1))
|
||||
(vector-set! count (sub1 r) r)
|
||||
(set! r (sub1 r)))
|
||||
(let ((flips2 (max (count-flips pi) flips)))
|
||||
(let ((result
|
||||
(let loop2 ()
|
||||
(if (= r n)
|
||||
flips2
|
||||
(let ((perm0 (vector-ref pi 0)))
|
||||
(do ((i 0))
|
||||
((>= i r))
|
||||
(let ((j (add1 i)))
|
||||
(vector-set! pi i (vector-ref pi j))
|
||||
(set! i j)))
|
||||
(vector-set! pi r perm0)
|
||||
(vector-set! count r (sub1 (vector-ref count r)))
|
||||
(cond ((<= (vector-ref count r) 0)
|
||||
(set! r (add1 r))
|
||||
(loop2))
|
||||
(else
|
||||
#f)))))))
|
||||
(or result
|
||||
(loop flips2 (add1 perms)))
|
||||
)))))
|
||||
(vector-set! count (sub1 r) r)
|
||||
(set! r (sub1 r)))
|
||||
(let ((flips2 (max (count-flips pi) flips)))
|
||||
(let ((result
|
||||
(let loop2 ()
|
||||
(if (= r n)
|
||||
flips2
|
||||
(let ((perm0 (vector-ref pi 0)))
|
||||
(do ((i 0))
|
||||
((>= i r))
|
||||
(let ((j (add1 i)))
|
||||
(vector-set! pi i (vector-ref pi j))
|
||||
(set! i j)))
|
||||
(vector-set! pi r perm0)
|
||||
(vector-set! count r (sub1 (vector-ref count r)))
|
||||
(cond ((<= (vector-ref count r) 0)
|
||||
(set! r (add1 r))
|
||||
(loop2))
|
||||
(else
|
||||
#f)))))))
|
||||
(or result
|
||||
(loop flips2 (add1 perms))))))))
|
||||
|
||||
(define (main args)
|
||||
(if (< (vector-length args) 1)
|
||||
(begin (display "An argument is required") (newline) 2)
|
||||
(let ((n (string->number (vector-ref args 0))))
|
||||
(if (not (integer? n))
|
||||
(begin (display "An integer is required") (newline) 2)
|
||||
(printf "Pfannkuchen(~S) = ~S~%" n (fannkuch n))))))
|
||||
|
||||
(main (current-command-line-arguments)))
|
||||
(command-line #:args (n)
|
||||
(printf "Pfannkuchen(~a) = ~a\n"
|
||||
n
|
||||
(fannkuch (string->number n))))
|
||||
|
|
|
|||
|
|
@ -6,114 +6,109 @@
|
|||
;; Derived from the Chicken variant, which was
|
||||
;; Contributed by Anthony Borla
|
||||
|
||||
(module fasta mzscheme
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
|
||||
(define +alu+
|
||||
(bytes-append
|
||||
#"GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG"
|
||||
#"GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA"
|
||||
#"CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT"
|
||||
#"ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA"
|
||||
#"GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG"
|
||||
#"AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC"
|
||||
#"AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"))
|
||||
(define +alu+
|
||||
(bytes-append
|
||||
#"GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG"
|
||||
#"GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA"
|
||||
#"CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT"
|
||||
#"ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA"
|
||||
#"GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG"
|
||||
#"AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC"
|
||||
#"AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"))
|
||||
|
||||
(define +iub+
|
||||
(list
|
||||
'(#\a . 0.27) '(#\c . 0.12) '(#\g . 0.12) '(#\t . 0.27) '(#\B . 0.02)
|
||||
'(#\D . 0.02) '(#\H . 0.02) '(#\K . 0.02) '(#\M . 0.02) '(#\N . 0.02)
|
||||
'(#\R . 0.02) '(#\S . 0.02) '(#\V . 0.02) '(#\W . 0.02) '(#\Y . 0.02)))
|
||||
(define +iub+
|
||||
(list
|
||||
'(#\a . 0.27) '(#\c . 0.12) '(#\g . 0.12) '(#\t . 0.27) '(#\B . 0.02)
|
||||
'(#\D . 0.02) '(#\H . 0.02) '(#\K . 0.02) '(#\M . 0.02) '(#\N . 0.02)
|
||||
'(#\R . 0.02) '(#\S . 0.02) '(#\V . 0.02) '(#\W . 0.02) '(#\Y . 0.02)))
|
||||
|
||||
(define +homosapien+
|
||||
(list
|
||||
'(#\a . 0.3029549426680) '(#\c . 0.1979883004921)
|
||||
'(#\g . 0.1975473066391) '(#\t . 0.3015094502008)))
|
||||
(define +homosapien+
|
||||
(list
|
||||
'(#\a . 0.3029549426680) '(#\c . 0.1979883004921)
|
||||
'(#\g . 0.1975473066391) '(#\t . 0.3015094502008)))
|
||||
|
||||
;; -------------
|
||||
;; -------------
|
||||
|
||||
(define +line-size+ 60)
|
||||
(define +line-size+ 60)
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(define (make-random seed)
|
||||
(let* ((ia 3877) (ic 29573) (im 139968) (last seed))
|
||||
(lambda (max)
|
||||
(set! last (modulo (+ ic (* last ia)) im))
|
||||
(/ (* max last) im) )))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(define (make-cumulative-table frequency-table)
|
||||
(let ([cumulative 0.0])
|
||||
(map
|
||||
(lambda (x)
|
||||
(set! cumulative (+ cumulative (cdr x)))
|
||||
(cons (char->integer (car x)) cumulative))
|
||||
frequency-table)))
|
||||
|
||||
;; -------------
|
||||
|
||||
(define random-next (make-random 42))
|
||||
(define +segmarker+ ">")
|
||||
|
||||
;; -------------
|
||||
|
||||
(define (select-random cumulative-table)
|
||||
(let ((rvalue (random-next 1.0)))
|
||||
(select-over-threshold rvalue cumulative-table)))
|
||||
|
||||
(define (select-over-threshold rvalue table)
|
||||
(if (<= rvalue (cdar table))
|
||||
(caar table)
|
||||
(select-over-threshold rvalue (cdr table))))
|
||||
|
||||
;; -------------
|
||||
|
||||
(define (repeat-fasta id desc n_ sequence line-length)
|
||||
(let ((seqlen (bytes-length sequence))
|
||||
(out (current-output-port)))
|
||||
(display (string-append +segmarker+ id " " desc "\n") out)
|
||||
(let loop-o ((n n_) (k 0))
|
||||
(unless (<= n 0)
|
||||
(let ((m (min n line-length)))
|
||||
(let loop-i ((i 0) (k k))
|
||||
(if (>= i m)
|
||||
(begin
|
||||
(newline out)
|
||||
(loop-o (- n line-length) k))
|
||||
(let ([k (if (= k seqlen) 0 k)])
|
||||
(write-byte (bytes-ref sequence k) out)
|
||||
(loop-i (add1 i) (add1 k))))))))))
|
||||
|
||||
;; -------------
|
||||
|
||||
(define (random-fasta id desc n_ cumulative-table line-length)
|
||||
(let ((out (current-output-port)))
|
||||
(display (string-append +segmarker+ id " " desc "\n") out)
|
||||
(let loop-o ((n n_))
|
||||
(unless (<= n 0)
|
||||
(let ((m (min n line-length)))
|
||||
(let loop-i ((i 0))
|
||||
(unless (>= i m)
|
||||
(write-byte (select-random cumulative-table) out)
|
||||
(loop-i (add1 i))))
|
||||
(newline out)
|
||||
(loop-o (- n line-length)))))))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
;; -------------------------------
|
||||
(let ((n (command-line #:args (n) (string->number n))))
|
||||
|
||||
(repeat-fasta "ONE" "Homo sapiens alu" (* n 2) +alu+ +line-size+)
|
||||
|
||||
(define (make-random seed)
|
||||
(let* ((ia 3877) (ic 29573) (im 139968) (last seed))
|
||||
(lambda (max)
|
||||
(set! last (modulo (+ ic (* last ia)) im))
|
||||
(/ (* max last) im) )))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(define (make-cumulative-table frequency-table)
|
||||
(let ((cumulative 0.0))
|
||||
(map
|
||||
(lambda (x)
|
||||
(set! cumulative (+ cumulative (cdr x)))
|
||||
(cons (char->integer (car x)) cumulative))
|
||||
frequency-table)))
|
||||
|
||||
;; -------------
|
||||
(random-fasta "TWO" "IUB ambiguity codes" (* n 3)
|
||||
(make-cumulative-table +iub+) +line-size+)
|
||||
|
||||
(define random-next (make-random 42))
|
||||
(define +segmarker+ ">")
|
||||
|
||||
;; -------------
|
||||
|
||||
(define (select-random cumulative-table)
|
||||
(let ((rvalue (random-next 1.0)))
|
||||
(select-over-threshold rvalue cumulative-table)))
|
||||
|
||||
(define (select-over-threshold rvalue table)
|
||||
(if (<= rvalue (cdar table))
|
||||
(caar table)
|
||||
(select-over-threshold rvalue (cdr table))))
|
||||
|
||||
;; -------------
|
||||
|
||||
(define (repeat-fasta id desc n_ sequence line-length)
|
||||
(let ((seqlen (bytes-length sequence))
|
||||
(out (current-output-port)))
|
||||
(display (string-append +segmarker+ id " " desc "\n") out)
|
||||
(let loop-o ((n n_) (k 0))
|
||||
(unless (<= n 0)
|
||||
(let ((m (min n line-length)))
|
||||
(let loop-i ((i 0) (k k))
|
||||
(if (>= i m)
|
||||
(begin
|
||||
(newline out)
|
||||
(loop-o (- n line-length) k))
|
||||
(let ([k (if (= k seqlen) 0 k)])
|
||||
(write-byte (bytes-ref sequence k) out)
|
||||
(loop-i (add1 i) (add1 k))))))))))
|
||||
|
||||
;; -------------
|
||||
|
||||
(define (random-fasta id desc n_ cumulative-table line-length)
|
||||
(let ((out (current-output-port)))
|
||||
(display (string-append +segmarker+ id " " desc "\n") out)
|
||||
(let loop-o ((n n_))
|
||||
(unless (<= n 0)
|
||||
(let ((m (min n line-length)))
|
||||
(let loop-i ((i 0))
|
||||
(unless (>= i m)
|
||||
(write-byte (select-random cumulative-table) out)
|
||||
(loop-i (add1 i))))
|
||||
(newline out)
|
||||
(loop-o (- n line-length)))))))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(define (main args)
|
||||
(let ((n (string->number (vector-ref args 0))))
|
||||
|
||||
(repeat-fasta "ONE" "Homo sapiens alu" (* n 2) +alu+ +line-size+)
|
||||
|
||||
(random-fasta "TWO" "IUB ambiguity codes" (* n 3)
|
||||
(make-cumulative-table +iub+) +line-size+)
|
||||
|
||||
(random-fasta "THREE" "Homo sapiens frequency" (* n 5)
|
||||
(make-cumulative-table +homosapien+) +line-size+) ))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(main (current-command-line-arguments)))
|
||||
|
||||
(random-fasta "THREE" "Homo sapiens frequency" (* n 5)
|
||||
(make-cumulative-table +homosapien+) +line-size+))
|
||||
|
|
|
|||
|
|
@ -15,137 +15,139 @@ Correct output N = 1000 is
|
|||
-0.169075164
|
||||
-0.169087605
|
||||
|#
|
||||
(module nbody mzscheme
|
||||
(require (only mzlib/string real->decimal-string))
|
||||
|
||||
;; ------------------------------
|
||||
;; define planetary masses, initial positions & velocity
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
|
||||
(define +pi+ 3.141592653589793)
|
||||
(define +days-per-year+ 365.24)
|
||||
;; ------------------------------
|
||||
;; define planetary masses, initial positions & velocity
|
||||
|
||||
(define +solar-mass+ (* 4 +pi+ +pi+))
|
||||
(define +pi+ 3.141592653589793)
|
||||
(define +days-per-year+ 365.24)
|
||||
|
||||
(define-struct body (x y z vx vy vz mass))
|
||||
(define +solar-mass+ (* 4 +pi+ +pi+))
|
||||
|
||||
(define *sun*
|
||||
(make-body 0.0 0.0 0.0 0.0 0.0 0.0 +solar-mass+))
|
||||
(define-struct body (x y z vx vy vz mass)
|
||||
#:mutable)
|
||||
|
||||
(define *jupiter*
|
||||
(make-body 4.84143144246472090
|
||||
-1.16032004402742839
|
||||
-1.03622044471123109e-1
|
||||
(* 1.66007664274403694e-3 +days-per-year+)
|
||||
(* 7.69901118419740425e-3 +days-per-year+)
|
||||
(* -6.90460016972063023e-5 +days-per-year+)
|
||||
(* 9.54791938424326609e-4 +solar-mass+)))
|
||||
(define *sun*
|
||||
(make-body 0.0 0.0 0.0 0.0 0.0 0.0 +solar-mass+))
|
||||
|
||||
(define *saturn*
|
||||
(make-body 8.34336671824457987
|
||||
4.12479856412430479
|
||||
-4.03523417114321381e-1
|
||||
(* -2.76742510726862411e-3 +days-per-year+)
|
||||
(* 4.99852801234917238e-3 +days-per-year+)
|
||||
(* 2.30417297573763929e-5 +days-per-year+)
|
||||
(* 2.85885980666130812e-4 +solar-mass+)))
|
||||
(define *jupiter*
|
||||
(make-body 4.84143144246472090
|
||||
-1.16032004402742839
|
||||
-1.03622044471123109e-1
|
||||
(* 1.66007664274403694e-3 +days-per-year+)
|
||||
(* 7.69901118419740425e-3 +days-per-year+)
|
||||
(* -6.90460016972063023e-5 +days-per-year+)
|
||||
(* 9.54791938424326609e-4 +solar-mass+)))
|
||||
|
||||
(define *uranus*
|
||||
(make-body 1.28943695621391310e1
|
||||
-1.51111514016986312e1
|
||||
-2.23307578892655734e-1
|
||||
(* 2.96460137564761618e-03 +days-per-year+)
|
||||
(* 2.37847173959480950e-03 +days-per-year+)
|
||||
(* -2.96589568540237556e-05 +days-per-year+)
|
||||
(* 4.36624404335156298e-05 +solar-mass+)))
|
||||
(define *saturn*
|
||||
(make-body 8.34336671824457987
|
||||
4.12479856412430479
|
||||
-4.03523417114321381e-1
|
||||
(* -2.76742510726862411e-3 +days-per-year+)
|
||||
(* 4.99852801234917238e-3 +days-per-year+)
|
||||
(* 2.30417297573763929e-5 +days-per-year+)
|
||||
(* 2.85885980666130812e-4 +solar-mass+)))
|
||||
|
||||
(define *neptune*
|
||||
(make-body 1.53796971148509165e+01
|
||||
-2.59193146099879641e+01
|
||||
1.79258772950371181e-01
|
||||
(* 2.68067772490389322e-03 +days-per-year+)
|
||||
(* 1.62824170038242295e-03 +days-per-year+)
|
||||
(* -9.51592254519715870e-05 +days-per-year+)
|
||||
(* 5.15138902046611451e-05 +solar-mass+)))
|
||||
(define *uranus*
|
||||
(make-body 1.28943695621391310e1
|
||||
-1.51111514016986312e1
|
||||
-2.23307578892655734e-1
|
||||
(* 2.96460137564761618e-03 +days-per-year+)
|
||||
(* 2.37847173959480950e-03 +days-per-year+)
|
||||
(* -2.96589568540237556e-05 +days-per-year+)
|
||||
(* 4.36624404335156298e-05 +solar-mass+)))
|
||||
|
||||
;; -------------------------------
|
||||
(define (offset-momentum system)
|
||||
(let loop-i ((i system) (px 0.0) (py 0.0) (pz 0.0))
|
||||
(if (null? i)
|
||||
(begin
|
||||
(set-body-vx! (car system) (/ (- px) +solar-mass+))
|
||||
(set-body-vy! (car system) (/ (- py) +solar-mass+))
|
||||
(set-body-vz! (car system) (/ (- pz) +solar-mass+)))
|
||||
(loop-i (cdr i)
|
||||
(+ px (* (body-vx (car i)) (body-mass (car i))))
|
||||
(+ py (* (body-vy (car i)) (body-mass (car i))))
|
||||
(+ pz (* (body-vz (car i)) (body-mass (car i))))))))
|
||||
(define *neptune*
|
||||
(make-body 1.53796971148509165e+01
|
||||
-2.59193146099879641e+01
|
||||
1.79258772950371181e-01
|
||||
(* 2.68067772490389322e-03 +days-per-year+)
|
||||
(* 1.62824170038242295e-03 +days-per-year+)
|
||||
(* -9.51592254519715870e-05 +days-per-year+)
|
||||
(* 5.15138902046611451e-05 +solar-mass+)))
|
||||
|
||||
;; -------------------------------
|
||||
(define (energy system)
|
||||
(let loop-o ((o system) (e 0.0))
|
||||
(if (null? o)
|
||||
e
|
||||
(let ([e (+ e (* 0.5 (body-mass (car o))
|
||||
(+ (* (body-vx (car o)) (body-vx (car o)))
|
||||
(* (body-vy (car o)) (body-vy (car o)))
|
||||
(* (body-vz (car o)) (body-vz (car o))))))])
|
||||
|
||||
(let loop-i ((i (cdr o)) (e e))
|
||||
(if (null? i)
|
||||
(loop-o (cdr o) e)
|
||||
(let* ((dx (- (body-x (car o)) (body-x (car i))))
|
||||
(dy (- (body-y (car o)) (body-y (car i))))
|
||||
(dz (- (body-z (car o)) (body-z (car i))))
|
||||
(distance (sqrt (+ (* dx dx) (* dy dy) (* dz dz)))))
|
||||
(let ([e (- e (/ (* (body-mass (car o)) (body-mass (car i))) distance))])
|
||||
(loop-i (cdr i) e)))))))))
|
||||
;; -------------------------------
|
||||
(define (offset-momentum system)
|
||||
(let loop-i ((i system) (px 0.0) (py 0.0) (pz 0.0))
|
||||
(if (null? i)
|
||||
(begin
|
||||
(set-body-vx! (car system) (/ (- px) +solar-mass+))
|
||||
(set-body-vy! (car system) (/ (- py) +solar-mass+))
|
||||
(set-body-vz! (car system) (/ (- pz) +solar-mass+)))
|
||||
(loop-i (cdr i)
|
||||
(+ px (* (body-vx (car i)) (body-mass (car i))))
|
||||
(+ py (* (body-vy (car i)) (body-mass (car i))))
|
||||
(+ pz (* (body-vz (car i)) (body-mass (car i))))))))
|
||||
|
||||
;; -------------------------------
|
||||
(define (advance system dt)
|
||||
(let loop-o ((o system))
|
||||
(unless (null? o)
|
||||
(let loop-i ((i (cdr o)))
|
||||
(unless (null? i)
|
||||
(let* ((o1 (car o))
|
||||
(i1 (car i))
|
||||
(dx (- (body-x o1) (body-x i1)))
|
||||
(dy (- (body-y o1) (body-y i1)))
|
||||
(dz (- (body-z o1) (body-z i1)))
|
||||
(distance (sqrt (+ (* dx dx) (* dy dy) (* dz dz))))
|
||||
(mag (/ dt (* distance distance distance)))
|
||||
(dxmag (* dx mag))
|
||||
(dymag (* dy mag))
|
||||
(dzmag (* dz mag))
|
||||
(om (body-mass o1))
|
||||
(im (body-mass i1)))
|
||||
(set-body-vx! o1 (- (body-vx o1) (* dxmag im)))
|
||||
(set-body-vy! o1 (- (body-vy o1) (* dymag im)))
|
||||
(set-body-vz! o1 (- (body-vz o1) (* dzmag im)))
|
||||
(set-body-vx! i1 (+ (body-vx i1) (* dxmag om)))
|
||||
(set-body-vy! i1 (+ (body-vy i1) (* dymag om)))
|
||||
(set-body-vz! i1 (+ (body-vz i1) (* dzmag om)))
|
||||
(loop-i (cdr i)))))
|
||||
(loop-o (cdr o))))
|
||||
|
||||
(let loop-o ((o system))
|
||||
(unless (null? o)
|
||||
(let ([o1 (car o)])
|
||||
(set-body-x! o1 (+ (body-x o1) (* dt (body-vx o1))))
|
||||
(set-body-y! o1 (+ (body-y o1) (* dt (body-vy o1))))
|
||||
(set-body-z! o1 (+ (body-z o1) (* dt (body-vz o1))))
|
||||
(loop-o (cdr o))))))
|
||||
;; -------------------------------
|
||||
(define (energy system)
|
||||
(let loop-o ((o system) (e 0.0))
|
||||
(if (null? o)
|
||||
e
|
||||
(let ([e (+ e (* 0.5 (body-mass (car o))
|
||||
(+ (* (body-vx (car o)) (body-vx (car o)))
|
||||
(* (body-vy (car o)) (body-vy (car o)))
|
||||
(* (body-vz (car o)) (body-vz (car o))))))])
|
||||
|
||||
(let loop-i ((i (cdr o)) (e e))
|
||||
(if (null? i)
|
||||
(loop-o (cdr o) e)
|
||||
(let* ((dx (- (body-x (car o)) (body-x (car i))))
|
||||
(dy (- (body-y (car o)) (body-y (car i))))
|
||||
(dz (- (body-z (car o)) (body-z (car i))))
|
||||
(distance (sqrt (+ (* dx dx) (* dy dy) (* dz dz)))))
|
||||
(let ([e (- e (/ (* (body-mass (car o)) (body-mass (car i))) distance))])
|
||||
(loop-i (cdr i) e)))))))))
|
||||
|
||||
;; -------------------------------
|
||||
;; -------------------------------
|
||||
(define (advance system dt)
|
||||
(let loop-o ((o system))
|
||||
(unless (null? o)
|
||||
(let loop-i ((i (cdr o)))
|
||||
(unless (null? i)
|
||||
(let* ((o1 (car o))
|
||||
(i1 (car i))
|
||||
(dx (- (body-x o1) (body-x i1)))
|
||||
(dy (- (body-y o1) (body-y i1)))
|
||||
(dz (- (body-z o1) (body-z i1)))
|
||||
(distance (sqrt (+ (* dx dx) (* dy dy) (* dz dz))))
|
||||
(mag (/ dt (* distance distance distance)))
|
||||
(dxmag (* dx mag))
|
||||
(dymag (* dy mag))
|
||||
(dzmag (* dz mag))
|
||||
(om (body-mass o1))
|
||||
(im (body-mass i1)))
|
||||
(set-body-vx! o1 (- (body-vx o1) (* dxmag im)))
|
||||
(set-body-vy! o1 (- (body-vy o1) (* dymag im)))
|
||||
(set-body-vz! o1 (- (body-vz o1) (* dzmag im)))
|
||||
(set-body-vx! i1 (+ (body-vx i1) (* dxmag om)))
|
||||
(set-body-vy! i1 (+ (body-vy i1) (* dymag om)))
|
||||
(set-body-vz! i1 (+ (body-vz i1) (* dzmag om)))
|
||||
(loop-i (cdr i)))))
|
||||
(loop-o (cdr o))))
|
||||
|
||||
(let ((n (string->number (vector-ref (current-command-line-arguments) 0)))
|
||||
(system (list *sun* *jupiter* *saturn* *uranus* *neptune*)))
|
||||
|
||||
(offset-momentum system)
|
||||
|
||||
(printf "~a~%" (real->decimal-string (energy system) 9))
|
||||
|
||||
(do ((i 1 (+ i 1)))
|
||||
((< n i))
|
||||
(advance system 0.01))
|
||||
(let loop-o ((o system))
|
||||
(unless (null? o)
|
||||
(let ([o1 (car o)])
|
||||
(set-body-x! o1 (+ (body-x o1) (* dt (body-vx o1))))
|
||||
(set-body-y! o1 (+ (body-y o1) (* dt (body-vy o1))))
|
||||
(set-body-z! o1 (+ (body-z o1) (* dt (body-vz o1))))
|
||||
(loop-o (cdr o))))))
|
||||
|
||||
(printf "~a~%" (real->decimal-string (energy system) 9))))
|
||||
;; -------------------------------
|
||||
|
||||
(let ((n (command-line #:args (n) (string->number n)))
|
||||
(system (list *sun* *jupiter* *saturn* *uranus* *neptune*)))
|
||||
|
||||
(offset-momentum system)
|
||||
|
||||
(printf "~a~%" (real->decimal-string (energy system) 9))
|
||||
|
||||
(do ((i 1 (+ i 1)))
|
||||
((< n i))
|
||||
(advance system 0.01))
|
||||
|
||||
(printf "~a~%" (real->decimal-string (energy system) 9)))
|
||||
|
|
|
|||
|
|
@ -3,44 +3,42 @@
|
|||
;; Based on the MLton version of the benchmark
|
||||
;; contributed by Scott Cruzen
|
||||
|
||||
;; Note: as of version 350, this benchmark spends most of
|
||||
;; its time GCing; it runs 3 times as fast in mzscheme3m.
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
|
||||
(module pidigits mzscheme
|
||||
(define (floor_ev q r s t x)
|
||||
(quotient (+ (* q x) r) (+ (* s x) t)))
|
||||
|
||||
(define (floor_ev q r s t x)
|
||||
(quotient (+ (* q x) r) (+ (* s x) t)))
|
||||
|
||||
(define (comp q r s t q2 r2 s2 t2)
|
||||
(values (+ (* q q2) (* r s2))
|
||||
(+ (* q r2) (* r t2))
|
||||
(+ (* s q2) (* t s2))
|
||||
(+ (* s r2) (* t t2))))
|
||||
(define (comp q r s t q2 r2 s2 t2)
|
||||
(values (+ (* q q2) (* r s2))
|
||||
(+ (* q r2) (* r t2))
|
||||
(+ (* s q2) (* t s2))
|
||||
(+ (* s r2) (* t t2))))
|
||||
|
||||
(define (next q r s t) (floor_ev q r s t 3))
|
||||
(define (safe? q r s t n) (= n (floor_ev q r s t 4)))
|
||||
(define (prod q r s t n) (comp 10 (* -10 n) 0 1 q r s t))
|
||||
(define (mk q r s t k) (comp q r s t k (* 2 (add1 (* 2 k))) 0 (add1 (* 2 k))))
|
||||
(define (next q r s t) (floor_ev q r s t 3))
|
||||
(define (safe? q r s t n) (= n (floor_ev q r s t 4)))
|
||||
(define (prod q r s t n) (comp 10 (* -10 n) 0 1 q r s t))
|
||||
(define (mk q r s t k) (comp q r s t k (* 2 (add1 (* 2 k))) 0 (add1 (* 2 k))))
|
||||
|
||||
(define (digit k q r s t n row col)
|
||||
(if (> n 0)
|
||||
(let ([y (next q r s t)])
|
||||
(if (safe? q r s t y)
|
||||
(let-values ([(q r s t) (prod q r s t y)])
|
||||
(if (= col 10)
|
||||
(let ([row (+ row 10)])
|
||||
(printf "\t:~a\n~a" row y)
|
||||
(digit k q r s t (sub1 n) row 1))
|
||||
(begin
|
||||
(printf "~a" y)
|
||||
(digit k q r s t(sub1 n) row (add1 col)))))
|
||||
(let-values ([(q r s t) (mk q r s t k)])
|
||||
(digit (add1 k) q r s t n row col))))
|
||||
(printf "~a\t:~a\n"
|
||||
(make-string (- 10 col) #\space)
|
||||
(+ row col))))
|
||||
(define (digit k q r s t n row col)
|
||||
(if (> n 0)
|
||||
(let ([y (next q r s t)])
|
||||
(if (safe? q r s t y)
|
||||
(let-values ([(q r s t) (prod q r s t y)])
|
||||
(if (= col 10)
|
||||
(let ([row (+ row 10)])
|
||||
(printf "\t:~a\n~a" row y)
|
||||
(digit k q r s t (sub1 n) row 1))
|
||||
(begin
|
||||
(printf "~a" y)
|
||||
(digit k q r s t(sub1 n) row (add1 col)))))
|
||||
(let-values ([(q r s t) (mk q r s t k)])
|
||||
(digit (add1 k) q r s t n row col))))
|
||||
(printf "~a\t:~a\n"
|
||||
(make-string (- 10 col) #\space)
|
||||
(+ row col))))
|
||||
|
||||
(define (digits n)
|
||||
(digit 1 1 0 0 1 n 0 0))
|
||||
(define (digits n)
|
||||
(digit 1 1 0 0 1 n 0 0))
|
||||
|
||||
(digits (string->number (vector-ref (current-command-line-arguments) 0))))
|
||||
(digits (command-line #:args (n) (string->number n)))
|
||||
|
|
|
|||
|
|
@ -1,60 +1,56 @@
|
|||
|
||||
(module reversecomplement mzscheme
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
|
||||
(define translation (make-vector 128))
|
||||
(define translation (make-vector 128))
|
||||
|
||||
(for-each (lambda (from-to)
|
||||
(let ([char (lambda (sym)
|
||||
(string-ref (symbol->string sym) 0))])
|
||||
(let ([from (char (car from-to))]
|
||||
[to (char->integer (char-upcase (char (cadr from-to))))])
|
||||
(vector-set! translation (char->integer from) to)
|
||||
(vector-set! translation (char->integer (char-upcase from)) to))))
|
||||
'([a t]
|
||||
[c g]
|
||||
[g c]
|
||||
[t a]
|
||||
[u a]
|
||||
[m k]
|
||||
[r y]
|
||||
[w w]
|
||||
[s s]
|
||||
[y R]
|
||||
[k M]
|
||||
[v b]
|
||||
[h d]
|
||||
[d h]
|
||||
[b v]
|
||||
[n n]))
|
||||
(for-each (lambda (from-to)
|
||||
(let ([char (lambda (sym)
|
||||
(string-ref (symbol->string sym) 0))])
|
||||
(let ([from (char (car from-to))]
|
||||
[to (char->integer (char-upcase (char (cadr from-to))))])
|
||||
(vector-set! translation (char->integer from) to)
|
||||
(vector-set! translation (char->integer (char-upcase from)) to))))
|
||||
'([a t]
|
||||
[c g]
|
||||
[g c]
|
||||
[t a]
|
||||
[u a]
|
||||
[m k]
|
||||
[r y]
|
||||
[w w]
|
||||
[s s]
|
||||
[y R]
|
||||
[k M]
|
||||
[v b]
|
||||
[h d]
|
||||
[d h]
|
||||
[b v]
|
||||
[n n]))
|
||||
|
||||
(define (output lines)
|
||||
(let* ([str (apply bytes-append lines)]
|
||||
[o (current-output-port)]
|
||||
[len (bytes-length str)])
|
||||
(let loop ([offset 0])
|
||||
(when (< offset len)
|
||||
(write-bytes str o offset (min len (+ offset 60)))
|
||||
(newline o)
|
||||
(loop (+ offset 60))))))
|
||||
|
||||
(let ([in (current-input-port)])
|
||||
(let loop ([accum null])
|
||||
(let ([l (read-bytes-line in)])
|
||||
(if (eof-object? l)
|
||||
(output accum)
|
||||
(cond
|
||||
[(regexp-match? #rx#"^>" l)
|
||||
(output accum)
|
||||
(printf "~a\n" l)
|
||||
(loop null)]
|
||||
[else
|
||||
(let* ([len (bytes-length l)]
|
||||
[dest (make-bytes len)])
|
||||
(let loop ([i 0][j (- len 1)])
|
||||
(unless (= i len)
|
||||
(bytes-set! dest
|
||||
j
|
||||
(vector-ref translation (bytes-ref l i)))
|
||||
(loop (add1 i) (sub1 j))))
|
||||
(loop (cons dest accum)))]))))))
|
||||
(define (output lines)
|
||||
(let* ([str (apply bytes-append lines)]
|
||||
[o (current-output-port)]
|
||||
[len (bytes-length str)])
|
||||
(for ([offset (in-range 0 len 60)])
|
||||
(write-bytes str o offset (min len (+ offset 60)))
|
||||
(newline o))))
|
||||
|
||||
(let ([in (current-input-port)])
|
||||
(let loop ([accum null])
|
||||
(let ([l (read-bytes-line in)])
|
||||
(if (eof-object? l)
|
||||
(output accum)
|
||||
(cond
|
||||
[(regexp-match? #rx#"^>" l)
|
||||
(output accum)
|
||||
(printf "~a\n" l)
|
||||
(loop null)]
|
||||
[else
|
||||
(let* ([len (bytes-length l)]
|
||||
[dest (make-bytes len)])
|
||||
(for ([i (in-range len)])
|
||||
(bytes-set! dest
|
||||
(- (- len i) 1)
|
||||
(vector-ref translation (bytes-ref l i))))
|
||||
(loop (cons dest accum)))])))))
|
||||
|
|
|
|||
|
|
@ -4,64 +4,55 @@
|
|||
;; Translated directly from the C# version, which was:
|
||||
;; contributed by Isaac Gouy
|
||||
|
||||
(module spectralnorm mzscheme
|
||||
(require mzlib/string)
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
|
||||
(define (Approximate n)
|
||||
(let ([u (make-vector n 1.0)]
|
||||
[v (make-vector n 0.0)])
|
||||
;; 20 steps of the power method
|
||||
(let loop ([i 0])
|
||||
(unless (= i 10)
|
||||
(MultiplyAtAv n u v)
|
||||
(MultiplyAtAv n v u)
|
||||
(loop (add1 i))))
|
||||
|
||||
;; B=AtA A multiplied by A transposed
|
||||
;; v.Bv /(v.v) eigenvalue of v
|
||||
(let loop ([i 0][vBv 0][vv 0])
|
||||
(if (= i n)
|
||||
(sqrt (/ vBv vv))
|
||||
(let ([vi (vector-ref v i)])
|
||||
(loop (add1 i)
|
||||
(+ vBv (* (vector-ref u i) vi))
|
||||
(+ vv (* vi vi))))))))
|
||||
(define (Approximate n)
|
||||
(let ([u (make-vector n 1.0)]
|
||||
[v (make-vector n 0.0)])
|
||||
;; 20 steps of the power method
|
||||
(for ([i (in-range 10)])
|
||||
(MultiplyAtAv n u v)
|
||||
(MultiplyAtAv n v u))
|
||||
|
||||
;; B=AtA A multiplied by A transposed
|
||||
;; v.Bv /(v.v) eigenvalue of v
|
||||
(let loop ([i 0][vBv 0][vv 0])
|
||||
(if (= i n)
|
||||
(sqrt (/ vBv vv))
|
||||
(let ([vi (vector-ref v i)])
|
||||
(loop (add1 i)
|
||||
(+ vBv (* (vector-ref u i) vi))
|
||||
(+ vv (* vi vi))))))))
|
||||
|
||||
;; return element i,j of infinite matrix A
|
||||
(define (A i j)
|
||||
(/ 1.0 (+ (* (+ i j) (/ (+ i j 1) 2)) i 1)))
|
||||
;; return element i,j of infinite matrix A
|
||||
(define (A i j)
|
||||
(/ 1.0 (+ (* (+ i j) (/ (+ i j 1) 2)) i 1)))
|
||||
|
||||
;; multiply vector v by matrix A
|
||||
(define (MultiplyAv n v Av)
|
||||
(let loop ([i 0])
|
||||
(unless (= i n)
|
||||
(let jloop ([j 0][r 0])
|
||||
(if (= j n)
|
||||
(vector-set! Av i r)
|
||||
(jloop (add1 j)
|
||||
(+ r (* (A i j) (vector-ref v j))))))
|
||||
(loop (add1 i)))))
|
||||
;; multiply vector v by matrix A
|
||||
(define (MultiplyAv n v Av)
|
||||
(for ([i (in-range n)])
|
||||
(vector-set! Av i
|
||||
(for/fold ([r 0])
|
||||
([j (in-range n)])
|
||||
(+ r (* (A i j) (vector-ref v j)))))))
|
||||
|
||||
;; multiply vector v by matrix A transposed
|
||||
(define (MultiplyAtv n v Atv)
|
||||
(let loop ([i 0])
|
||||
(unless (= i n)
|
||||
(let jloop ([j 0][r 0])
|
||||
(if (= j n)
|
||||
(vector-set! Atv i r)
|
||||
(jloop (add1 j)
|
||||
(+ r (* (A j i) (vector-ref v j))))))
|
||||
(loop (add1 i)))))
|
||||
;; multiply vector v by matrix A transposed
|
||||
(define (MultiplyAtv n v Atv)
|
||||
(for ([i (in-range n)])
|
||||
(vector-set! Atv i
|
||||
(for/fold ([r 0])
|
||||
([j (in-range n)])
|
||||
(+ r (* (A j i) (vector-ref v j)))))))
|
||||
|
||||
;; multiply vector v by matrix A and then by matrix A transposed
|
||||
(define (MultiplyAtAv n v AtAv)
|
||||
(let ([u (make-vector n 0.0)])
|
||||
(MultiplyAv n v u)
|
||||
(MultiplyAtv n u AtAv)))
|
||||
;; multiply vector v by matrix A and then by matrix A transposed
|
||||
(define (MultiplyAtAv n v AtAv)
|
||||
(let ([u (make-vector n 0.0)])
|
||||
(MultiplyAv n v u)
|
||||
(MultiplyAtv n u AtAv)))
|
||||
|
||||
(printf "~a\n"
|
||||
(real->decimal-string
|
||||
(Approximate (command-line #:args (n) (string->number n)))
|
||||
9))
|
||||
|
||||
(printf "~a\n"
|
||||
(real->decimal-string
|
||||
(Approximate (string->number (vector-ref
|
||||
(current-command-line-arguments)
|
||||
0)))
|
||||
9)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user