@@ -748,21 +748,24 @@ (define (arc-list? x) (or (pair? x) (eqv? x 'nil) (eqv? x '()))) -; generic +: strings, lists, numbers. -; problem with generic +: what to return when no args? -; could even coerce based on type of first arg... +; Generic +: strings, lists, numbers. +; Return val has same type as first argument. (xdef + (lambda args (cond ((null? args) 0) - ((all string? args) - (apply string-append args)) - ((all arc-list? args) + ((char-or-string? (car args)) + (apply string-append + (map (lambda (a) (ar-coerce a 'string)) + args))) + ((arc-list? (car args)) (ac-niltree (apply append (map ar-nil-terminate args)))) (#t (apply + args))))) +(define (char-or-string? x) (or (string? x) (char? x))) + (define (ar-+2 x y) - (cond ((and (string? x) (string? y)) - (string-append x y)) + (cond ((char-or-string? x) + (string-append (ar-coerce x 'string) (ar-coerce y 'string))) ((and (arc-list? x) (arc-list? y)) (ac-niltree (append (ar-nil-terminate x) (ar-nil-terminate y)))) (#t (+ x y)))) @@ -938,47 +941,52 @@ (define (iround x) (inexact->exact (round x))) -(xdef coerce - (lambda (x type . args) - (cond - ((ar-tagged? x) (err "Can't coerce annotated object")) - ((eqv? type (ar-type x)) x) - ((char? x) (case type - ((int) (char->ascii x)) - ((string) (string x)) - ((sym) (string->symbol (string x))) - (else (err "Can't coerce" x type)))) - ((integer? x) (case type - ((num) x) - ((char) (ascii->char x)) - ((string) (apply number->string x args)) - (else (err "Can't coerce" x type)))) - ((number? x) (case type - ((int) (iround x)) - ((char) (ascii->char (iround x))) - ((string) (apply number->string x args)) - (else (err "Can't coerce" x type)))) - ((string? x) (case type - ((sym) (string->symbol x)) - ((cons) (ac-niltree (string->list x))) - ((num) (or (apply string->number x args) - (err "Can't coerce" x type))) - ((int) (let ((n (apply string->number x args))) - (if n - (iround n) - (err "Can't coerce" x type)))) - (else (err "Can't coerce" x type)))) - ((pair? x) (case type - ((string) (list->string - (ar-nil-terminate x))) - (else (err "Can't coerce" x type)))) - ((eqv? x 'nil) (case type - ((string) "") - (else (err "Can't coerce" x type)))) - ((symbol? x) (case type - ((string) (symbol->string x)) - (else (err "Can't coerce" x type)))) - (#t x)))) +(define (ar-coerce x type . args) + (cond + ((ar-tagged? x) (err "Can't coerce annotated object")) + ((eqv? type (ar-type x)) x) + ((char? x) (case type + ((int) (char->ascii x)) + ((string) (string x)) + ((sym) (string->symbol (string x))) + (else (err "Can't coerce" x type)))) + ((integer? x) (case type + ((num) x) + ((char) (ascii->char x)) + ((string) (apply number->string x args)) + (else (err "Can't coerce" x type)))) + ((number? x) (case type + ((int) (iround x)) + ((char) (ascii->char (iround x))) + ((string) (apply number->string x args)) + (else (err "Can't coerce" x type)))) + ((string? x) (case type + ((sym) (string->symbol x)) + ((cons) (ac-niltree (string->list x))) + ((num) (or (apply string->number x args) + (err "Can't coerce" x type))) + ((int) (let ((n (apply string->number x args))) + (if n + (iround n) + (err "Can't coerce" x type)))) + (else (err "Can't coerce" x type)))) + ((pair? x) (case type + ((string) (apply string-append + (map (lambda (y) (ar-coerce y 'string)) + (ar-nil-terminate x)))) + (else (err "Can't coerce" x type)))) + ((eqv? x 'nil) (case type + ((string) "") + (else (err "Can't coerce" x type)))) + ((null? x) (case type + ((string) "") + (else (err "Can't coerce" x type)))) + ((symbol? x) (case type + ((string) (symbol->string x)) + (else (err "Can't coerce" x type)))) + (#t x))) + +(xdef coerce ar-coerce) (xdef open-socket (lambda (num) (tcp-listen num 50 #t))) @@ -1357,13 +1365,12 @@ (xdef memory current-memory-use) (xdef declare (lambda (key val) - (case key - ((atstrings) - (set! atstrings (not (eq? val 'nil)))) - ((direct-calls) - (set! direct-calls (not (eq? val 'nil)))) - ((explicit-flush) - (set! explicit-flush (not (eq? val 'nil))))))) + (let ((flag (not (ar-false? val)))) + (case key + ((atstrings) (set! atstrings flag)) + ((direct-calls) (set! direct-calls flag)) + ((explicit-flush) (set! explicit-flush flag))) + val))) (putenv "TZ" ":GMT") @@ -1382,6 +1389,9 @@ (xdef sin sin) (xdef cos cos) (xdef tan tan) +(xdef asin asin) +(xdef acos acos) +(xdef atan atan) (xdef log log) (define (codestring s) ac.scm @@ -219,6 +219,9 @@ (def testify (x) (if (isa x 'fn) x [is _ x])) +; Like keep, seems like some shouldn't testify. But find should, +; and all probably should. + (def some (test seq) (let f (testify test) (if (alist seq) @@ -512,6 +515,11 @@ seq) (coerce (rem test (coerce seq 'cons)) 'string)))) +; Seems like keep doesn't need to testify-- would be better to +; be able to use tables as fns. But rem does need to, because +; often want to rem a table from a list. So maybe the right answer +; is to make keep the more primitive, not rem. + (def keep (test seq) (rem (complement (testify test)) seq)) @@ -1634,7 +1642,7 @@ (def ratio (test xs) (if (empty xs) 0 - (/ (count (testify test) xs) (len xs)))) + (/ (count test xs) (len xs)))) ; any logical reason I can't say (push x (if foo y z)) ? @@ -1681,6 +1689,7 @@ ; foo_bar means [foo _ bar] ; what does foo:_:bar mean? ; matchcase +; idea: atable that binds it to table, assumes input is a list ; crazy that finding the top 100 nos takes so long: ; (let bb (n-of 1000 (rand 50)) (time10 (bestn 100 > bb))) ; time: 2237 msec. -> now down to 850 msec arc.arc @@ -38,6 +38,7 @@ To improve performance: (= static-max-age* 7200) ; browsers can cache static files for 7200 sec -(declare direct-calls t) ; you promise not to redefine fns as tables +(declare 'direct-calls t) ; you promise not to redefine fns as tables -(declare explicit-flush t) ; you take responsibility for flushing output +(declare 'explicit-flush t) ; you take responsibility for flushing output + ; (all existing news code already does) how-to-run-news @@ -1,6 +1,6 @@ ; News. 2 Sep 06. -; to run news: (nsv) +; to run news: (nsv), then go to http://localhost:8080 ; put usernames of admins, separated by whitespace, in arc/admins ; bug: somehow (+ votedir* nil) is getting evaluated. @@ -189,7 +189,7 @@ (def apoll (i) (is i!type 'poll)) (def load-item (id) - (let i (temload 'item (string storydir* id)) + (let i (temload 'item (+ storydir* id)) (= (items* id) i) (awhen (and (astory+live i) (check i!url ~blank)) (register-url i it)) @@ -211,7 +211,7 @@ url)) (def new-item-id () - (evtil (++ maxid*) [~file-exists (string storydir* _)])) + (evtil (++ maxid*) [~file-exists (+ storydir* _)])) (def item (id) (or (items* id) (errsafe:load-item id))) @@ -232,7 +232,7 @@ (def live (i) (nor i!dead i!deleted)) -(def save-item (i) (save-table i (string storydir* i!id))) +(def save-item (i) (save-table i (+ storydir* i!id))) (def kill (i how) (unless i!dead @@ -901,7 +901,7 @@ function vote(node) { (hook 'listspage user)))) -(def saved-url (user) (string "saved?id=" user)) +(def saved-url (user) (+ "saved?id=" user)) (newsop saved (id) (if (only.profile id) @@ -1053,7 +1053,7 @@ function vote(node) { (votelink i user whence 'down)) ; don't understand why needed, but is, or a new ; page is generated on voting - (tag (span id (string "down_" i!id))))) + (tag (span id (+ "down_" i!id))))) (author user i) (do (fontcolor orange (pr "*")) (br) @@ -1074,10 +1074,9 @@ function vote(node) { (out (gentag img src down-url* border 0 vspace 3 hspace 2))))) (def vote-url (user i dir whence) - (+ "vote?" (if user (+ "by=" user "&") "") - "for=" (coerce i!id 'string) - "&dir=" (coerce dir 'string) - (if user (string "&auth=" (user->cookie* user)) "") + (+ "vote?" "for=" i!id + "&dir=" dir + (if user (+ "&by=" user "&auth=" (user->cookie* user))) "&whence=" (urlencode whence))) (= lowest-score* -8) @@ -1129,7 +1128,7 @@ function vote(node) { (byline i user))) (def itemscore (i (o user)) - (tag (span id (string "score_" i!id)) + (tag (span id (+ "score_" i!id)) (pr (plural (if (is i!type 'pollopt) (realscore i) i!score) "point"))) (hook 'itemscore i user)) @@ -1554,10 +1553,10 @@ function vote(node) { (if (isa (saferead (car toks)) 'int) (tostring (prall toks "" ".")) (let (t1 t2 t3 . rest) toks - (if (or (mem t1 multi-tld-countries*) - (and t3 (mem t2 long-domains*))) - (string t3 "." t2 "." t1) - (string t2 "." t1))))))) + (if (and t3 (or (mem t1 multi-tld-countries*) + (mem t2 long-domains*))) + (+ t3 "." t2 "." t1) + (and t2 (+ t2 "." t1)))))))) ; Minor bug: can have both google.at and google.co.at. Same for jp. @@ -1771,7 +1770,7 @@ function vote(node) { ; Individual Item Page (= Comments Page of Stories) -(defmemo item-url (id) (string "item?id=" id)) +(defmemo item-url (id) (+ "item?id=" id)) (newsop item (id) (let s (safe-item id) @@ -1825,6 +1824,7 @@ function vote(node) { (def comments-active (i) (and (live+commentable i) + (live (superparent i)) (or (< (item-age i) commentable-threshold*) (mem 'commentable i!keys)))) @@ -1859,7 +1859,7 @@ function vote(node) { ; Edit Item -(def edit-url (i) (string "edit?id=" i!id)) +(def edit-url (i) (+ "edit?id=" i!id)) (newsop edit (id) (let i (safe-item id) @@ -2129,7 +2129,7 @@ function vote(node) { (> (item-age c) (expt (- indent 1) reply-decay*)))) (def replylink (i whence (o title 'reply)) - (link title (string "reply?id=" i!id "&whence=" (urlencode whence)))) + (link title (+ "reply?id=" i!id "&whence=" (urlencode whence)))) (newsop reply (id whence) (with (i (safe-item id) news.arc 36291c44fd67b38bdb6a52be70bc81cbebd102d1 pg and rtm <> http://github.com/nex3/arc/commit/fa2d724d960eb51c10d1653921c0ae72a580789f fa2d724d960eb51c10d1653921c0ae72a580789f 2009-06-24T17:48:14-07:00 2009-06-24T17:48:14-07:00 arc3.tar: clearer +, inverse trig functions 5141e598cda6975f2734972b0c0240f186655603 Michael Arntzenius daekharel@gmail.com