Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

779 lines (714 sloc) 48.625 kb
(module rhizome racket
;;TOP TODO:
;;Add eval
;;TODO: Make lazy evaluator that evals directly from database.
;Advantages:
;easier than calling eval and read
;allows control over syntax
;can reduce the amount of reads by short circuting (Really important if meta-attributes are read)
;might be able to nicely tie into function caching code.
;simplifies evaluating self-refrencing code.
;/usr/share/racket/collects/
(require web-server/servlet-env)
(require web-server/http/bindings
web-server/http/response-structs
web-server/http/xexpr)
(define (response/text text)
(response/full
200 #"Ok"
(current-seconds) TEXT/HTML-MIME-TYPE
(list)
(list (string->bytes/utf-8 text))))
;;;;;;;;;;;;;;;;;;;;;; helper functions ;;;;;;;;;;;;;;;;;;
;;Most of these are helpers for my arguement passing scheme for the read and read-2-HTML functions.
;;(I plan to extend it to all functions eventually)
;;The args list is treated sort of like an associative list of pairs
;;except, rather than do list surgery to change certain keys,
;;I just append a new key with the new value,
;;and only look for the first instance of the key.
;;It's sort of like call stack in that it grows with every funciton call.
;;The reason to do this is it allows more flexibility in changing function.
;;If an arguement is no longer used, it can still be included in some function calls without breaking anything.
(define (getarg args arg (default-value #f))
(cadr (or (findf (lambda (k)
(and (pair? k)
(eq? (car k) arg)))
args)
(list 'default-value default-value))))
(define (setarg args arg value)
(cons (list arg value) args))
(define (decarg args arg (default-value #f))
(let ((current-value (getarg args arg default-value)))
(if current-value
(if (positive? current-value)
(cons (list arg (- current-value 1)) args)
(error "Arg is not positive"))
(error "Arg not initialized"))))
(define (meta? entry) (and (pair? entry) (eq? 'meta (car entry))))
(define (branch? entry) (and (pair? entry) (eq? 'branch (car entry))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DATABASE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The database is just a auto-resizing vector with a size counter.
;; If I were to reimplement this, I would intead use gensym and create new symbol bindings in the env for each entry.
;; I would also allow using the modify function to put entries at given names, and do lookups based on that.
;; (namespace-mapped-symbols (make-base-empty-namespace))
;;Note: database functions should not be used directly but instead called from the core functions.
(display "Creating database...")
(define-struct database (entries offset) #:mutable)
(define DATABASE (make-database (make-vector 100) 0))
(define STATIC-DATABASE (make-database (make-vector 100) 0))
;;database-ref can be exposed
(define (database-ref db index)
(vector-ref (database-entries db) index))
;;database-set! must be protected.
(define (database-set! db index element)
(vector-set! (database-entries db) index element))
;;database-append I'm not sure about, it shouldn't be spammed.
(define (database-append db sexp)
(let ((offset (database-offset db))
(capacity (vector-length (database-entries db))))
(begin (if (>= offset capacity)
(set-database-entries! db (vector-append (database-entries db) (make-vector capacity))) void)
(vector-set! (database-entries db) offset sexp)
(set-database-offset! db (+ 1 offset))
offset)))
;;debug functions.
(define (ddump) (database-entries DATABASE))
(define (dread idx) (READ-FUN (list 'entry (if (box? idx) idx (box idx)))))
(define (dref idx) (database-ref DATABASE (if (box? idx) (unbox idx) idx)))
(define (dfind addr)
(let ((addr (if (box? addr) (unbox addr) addr)))
(vector-filter (lambda (k)
(and (pair? k)
(ormap (lambda (n)
(and (box? n)
(equal? (unbox n) addr)))
k)))
(ddump))))
(display "Database ready.")(newline)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; initial core functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;I'm intentionally trying to avoid using variables.
;;Since code can directly refrence itself, there is no reason to bind it to a name.
;;Names are also convenient because they hide code (i.e. the word factorial instead of the code for the factorial function)
;;but this can be done using meta-expressions with a read-2-HTML parameter.
;;However, for bootstraping always using refrences would be too cumbersome and it might not be possible in some cases.
;;Discussion of whether to implement voting and other policies at the read time or write time:
;;;;;;;;read time pro
;Predictable modifies (1) --- If I have a static db modifies are still pretty predictable. Not as bad as parent pointers.
;No need for static entries since read logic can make things stable.(4)
;;;;;;;;read time con
;Slower as more modifies accumulate and as policies become complex.(2)
;Multiple database readers need to account for the policy.(3)
;;;;;;;;write time pro
;Faster since writes are very rare compared to reads.(2)
;Only one modify function. (3)
;Simpler code in the database makes the system more flexible.(5)
;;;;;;;;write time con
;Static entries or parent refs necessairy since meta child elements can always be modified. (4)
;unpredictable modifies. (1)
(define init-create-code
'(letrec ((self
(lambda args
(let ((new_code (getarg args 'new_code))
(is-static (getarg args 'is-static))
(symbol-bindings (getarg args 'symbol-bindings null)));;This lets you do things like bind #&previous to the previous entry
(let ((return-value
(if (pair? new_code)
(let ((next-args (append (if (eq? (car new_code) 'meta)
'((is-static #t))
null)
args)))
(map (lambda (code-element)
;(display self)
(cond ((box? code-element)
(let ((unboxed-element (unbox code-element)))
(cond ((symbol? unboxed-element)
(getarg symbol-bindings unboxed-element (box 1)));;TODO PROBLEM
((number? unboxed-element) code-element) ;;Boxed integers allow you to link directly other places in the db.
(else (error (string-append "Bad address: " (format "~a" code-element)))))))
((and (pair? code-element) (eq? 'unmeta (car code-element)))
(apply self (append (list (list 'new_code (cadr code-element))
(list 'is-static #f))
next-args)))
(else (apply self (append (list (list 'new_code code-element))
next-args)))))
new_code))
new_code)))
(if is-static
return-value
(box (database-append DATABASE return-value))))))))
self))
;;As code is read from the array I want to create a table with the value of every entry read so that cycle can be detected.
;;The reason it is so messy is I replace cyclic refrences with lets.
;;I would like to make a pure functional version that puts the lets as far down as possible.
;;I'm not sure if having all the lets at the top is a good idea or not.
;;I'm also considering a version that creates database read and eval commands when a cycle is detected.
(define init-read-code
'(letrec ((self
(lambda args
(let ((entry (getarg args 'entry))
(address (getarg args 'address))
(hash (getarg args 'hash)))
(if (not hash);;Initial invokation
(let* ((hash (make-hash))
(body (apply self (setarg args 'hash hash)));;This let has to happen first. Will probably cause a problem in lazy eval
(filtered-hash-list (filter (lambda (k)
(not (void? (cdr k))))
(hash->list hash))))
(if (null? filtered-hash-list)
body
(list 'letrec (map (lambda (key-val)
(list (car key-val) (cdr key-val)))
filtered-hash-list)
body)))
(cond ((box? entry)
(let ((unboxed-entry (unbox entry)))
(apply self (setarg (setarg args
'entry (database-ref DATABASE unboxed-entry))
'address unboxed-entry))))
((pair? entry)
(if (eq? 'meta (car entry))
(apply self (setarg args 'entry (cadr entry)))
(begin
(let ((address-symbol (if address
(string->symbol (number->string address))
(gensym))))
(if (hash-has-key? hash address-symbol)
(begin (hash-set! hash address-symbol (box (hash-ref hash address-symbol)))
address-symbol)
(begin (hash-set! hash address-symbol (void))
(let ((return-value (map (lambda (k)
(apply self (setarg args 'entry k)))
entry)))
(if (void? (hash-ref hash address-symbol))
return-value
(begin (hash-set! hash address-symbol return-value)
return-value)))))))))
(else entry)))))))
self))
(define init-read-code-simplified
'(letrec ((self
(lambda args
(let ((entry (getarg args 'entry)))
(cond ((box? entry)
(apply self (setarg args 'entry (database-ref DATABASE (unbox entry)))))
((pair? entry)
(if (eq? 'meta (car entry))
(apply self (setarg args 'entry (cadr entry)))
(map (lambda (k)
(apply self (setarg args 'entry k))) entry)))
(else entry))))))
self))
(define init-eval-code
`(lambda args
(let ((entry (getarg args 'entry)))
;(display args)
;(newline)
;(display (READ-FUN (list 'entry entry)))
;(newline)
(eval (apply READ-FUN args) ns))))
;;TODO: Record parent type in args
(define init-read-2-HTML-code
'(letrec ((self
(lambda args
(let* ((entry (getarg args 'entry)) ;;Every call must at least have an entry
(number-address (unbox (getarg args 'address (box -1))))
(string-address (number->string number-address))
(class-prefix (getarg args 'class-prefix "")))
(cond ((zero? (getarg args 'depth 9))
`(div ((class "maxdepth sexp") (id ,string-address)) ""))
((box? entry)
(apply self (append `((entry ,(database-ref DATABASE (unbox entry)))
(address ,entry))
(if (eq? class-prefix "static ");;TODO: Generalize this
'((class-prefix ""))
null)
args)))
((list? entry)
(let ((args (append (if (meta? entry)
'((class-prefix "static "))
null)
(if (eq? class-prefix "branch ")
'((class-prefix ""))
null)
args)))
(if (meta? entry)
(append `(div ((class ,(string-append "meta sexp"
(if (getarg args 'examine)
" examined" "")))
(id ,string-address)))
(let* ((meta-attrs (cddr entry))
(read-2-HTML-function (getarg meta-attrs 'read-2-HTML-function))
(next-args (append `((entry ,(cadr entry))
(meta-attrs ,meta-attrs)
(examine #f))
(decarg args 'depth 9))))
;(begin (display read-2-HTML-function)(newline))
(if (getarg args 'examine)
(map (lambda (k)
(apply self (append `((entry ,k)) next-args)))
entry)
(list (cond (read-2-HTML-function
(apply (EVAL-FUN (list 'entry read-2-HTML-function)) next-args))
(else (apply self next-args)))))))
(append `(div ((class ,(string-append class-prefix "sexp"))
(id ,string-address)) "")
(let ((next-args (append
(if (getarg args 'examine)
'((examine #f))
null)
(decarg args 'depth 9))))
(map (lambda (k)
(apply self (setarg next-args 'entry k)))
entry))))))
(else (let ((type-value ;;TODO: Get type function?
(cond ((eq? entry 'lambda) (list "symbol lambda" entry))
((symbol? entry) (list "symbol" (format "~a" entry)))
((number? entry) (list "number" (format "~a" entry)))
((char? entry) (list "char" (format "~a" entry)))
((boolean? entry) (list "boolean" (format "~a" entry)))
((keyword? entry) (list "keyword" (keyword->string entry)))
((string? entry) (list "string" (string-append "\"" entry "\"")))
(else (list "unknown" (format "~a" entry))))));;TODO can the above be replaced by format?
`(div ((class ,(string-append class-prefix "primative" " " (car type-value))) (id ,string-address))
,(cadr type-value)))))))))
self))
;;Right now I'm thinking a branch should look like this:
;;(meta #&main-branch-addr (votes 1) (branch #&branch-addr (votes 0)))
;;This way it will be possible to refrence a branch without worrying if it is elected,
;;which might be a bad idea in some cases
;;(e.g. a deprecated branch might refrence nodes that change without regard for it, in which case it would be better to copy it),
;;but it is definately useful if a branch links to a previous branch.
;;If branch branching is a problem some branches can be made static.
;;Also, I'm thinking about including a modify-function meta-attr
;;Maybe I should be updating votes idependently and then updating the main branch.
(define init-modify-code
'(lambda args
(let* ((address (getarg args 'address "Address not specified"))
(new_code (getarg args 'new_code))
(make-votes (lambda args
(CREATE-FUN (list 'new_code
(list 'meta (getarg args 'amount 0)
`(read-2-HTML-function ;;TODO: vote interface should be refed
(unmeta
(lambda args
(let ((meta-attrs (getarg args 'meta-attrs)))
`(div ((class "votes"))
(p "votes:")
,(apply READ-2-HTML-FUN args)
(button ((idx ,(number->string
(unbox (getarg meta-attrs
'election))))
(new_code
,(string-append
"#&"
(number->string
(unbox (getarg meta-attrs
'votes-for)))))
(class "vote_button"))
"+1"))))))
`(election ,(getarg args 'election))
`(votes-for ,(getarg args 'votes-for)))))))
(current (database-ref DATABASE (unbox address)))
;;Make a copy of the current branch.
;;This definately wastes space in most cases but it makes things a little easier.
(current-copy (CREATE-FUN (list 'new_code current)))
(test (begin (newline)(display current-copy)(newline)))
(new-branch-entry (if (box? new_code)
new_code
(CREATE-FUN (list 'new_code new_code)
(list 'symbol-bindings
;;TODO: Might be buggy with metas, but it's not clear to me what the expected behavior should be there anyways
(list (list 'previous current-copy))))))
(new-branch (list 'branch new-branch-entry
(list 'votes (make-votes
'(amount 1)
(list 'votes-for new-branch-entry)
(list 'election address)))))
(new-entry
(cond ((equal? current new_code) #f);;This shouldn't happen, but if it does, this check should be done before the new branch is created
((meta? current)
;;LETS!!
(let* ((count-votes (lambda (k)
(READ-FUN (list 'entry (cadar (cddr k))))))
#;(increment-votes (lambda (k (amount 1))
(list 'branch (cadr k)
(list 'votes (+ amount (count-votes k))))))
(meta-attrs (cddr current)))
(display "Getting vote attributes...")
(let-values (((main-branch-voteses non-vote-params)
(partition
(lambda (k)
(and (pair? k)
(equal? 'votes (car k))))
meta-attrs)))
(let* ((main-branch (list 'branch (cadr current)
(if (null? main-branch-voteses)
(list 'votes (make-votes
(list 'votes-for (cadr current))
(list 'election address)))
(car main-branch-voteses)))))
(display "Getting branches...")
(let-values (((branches other-params)
(partition
(lambda (k)
(and (pair? k)
(equal? 'branch (car k))))
non-vote-params)))
(let ((all-branches (cons new-branch (cons main-branch branches))))
(display "Finding branch(es?) that matches new_code...")
(let-values (((matching-branches other-branches)
(partition
(lambda (k)
(equal? (cadr k) new_code));;important for this to be equal? and not eq?
all-branches)))
(display "Updating votes...")
(let ((updated-branches (cons (append
(take new-branch 2)
`((votes ,(make-votes
(list 'amount
(apply + (map (lambda (k)
(count-votes k))
matching-branches)))
(list 'votes-for (cadr new-branch))
(list 'election address)))))
other-branches)))
(display "Finding top branch...")
;;Note the order of updated-branches is important,
;;Since sort is stable, and matching branches are first,
;;they will be chosen in a tie breaker. (Newer = slightly better)
(let ((sorted-branches (sort updated-branches
(lambda (a b)
(> (count-votes a)
(count-votes b))))))
(let ((elected-branch (car sorted-branches)))
(append (list 'meta) (cdr elected-branch)
(cdr sorted-branches)
other-params)))))))))))
(else
(append (list 'meta)
(cdr new-branch)
(list (list 'branch current-copy `(votes ,(make-votes
(list 'votes-for current-copy)
(list 'election address))))
(list 'read-2-HTML-function
;;TODO: Link to this by address
`(lambda args
(let* ((entry (getarg args 'entry)) ;;Every call must at least have an entry
(number-address (unbox (getarg args 'address (box -1))))
(string-address (number->string number-address))
(meta-attrs (getarg args 'meta-attrs null))
(votes (getarg meta-attrs 'votes))
(branches (filter (lambda (k)
(and (pair? k)
(branch? k)))
meta-attrs)))
`(div ((class "branch") (id ,string-address))
,(if votes `(div ((class "element_button top_inner_button"))
,(READ-2-HTML-FUN (list 'entry votes))) "")
,(apply READ-2-HTML-FUN args)
(div ((class "element_button bottom_inner_button"))
(p "Alternate branches:")
,(append '(div ((class "alt-branches")) "")
(map (lambda (k)
(let ((branch-link (number->string
(unbox (cadr k)))))
`(a ((href ,(string-append "?idx=" branch-link)))
,branch-link)))
branches)))
)))
)))))))
;(newline)(display "current ")(display current)(newline)
;(newline)(display "new_code ")(display new_code)(newline)
;(newline)(display new-entry)(newline)
(if new-entry
(begin
(database-set! DATABASE (unbox address) new-entry)
;;This unschemely code flushes the cached functions when ever anything is modified.
;;More advanced would be to have every db entry cached and keep parent pointer lists to keep track of when something needs to be updated.
;;I'm trying to order these so that the effects of the changes don't take place before the update is finished.
(hash-set! CORE 'read-2-HTML (EVAL-FUN (list 'entry READ-2-HTML-FUN-ADDRESS)))
(hash-set! CORE 'handler (EVAL-FUN (list 'entry HANDLER-FUN-ADDRESS)))
(hash-set! CORE 'modify (EVAL-FUN (list 'entry MODIFY-FUN-ADDRESS)))
(hash-set! CORE 'eval (EVAL-FUN (list 'entry EVAL-FUN-ADDRESS)));;What happens here?
(hash-set! CORE 'read (EVAL-FUN (list 'entry READ-FUN-ADDRESS)))
(hash-set! CORE 'create (EVAL-FUN (list 'entry CREATE-FUN-ADDRESS)))
(display "Cached functions updated.")
#t)
#f
))))
;;I want to switch to getting addresses out of urls.
;;http://docs.racket-lang.org/web-server/dispatch.html
(define init-handler-code
'(lambda (db request)
(let* ((bindings (request-bindings request))
(bindings-assoc (map (lambda (k)
(list (car k) (read (open-input-string (cdr k)))))
bindings))
(addr (if (exists-binding? 'idx bindings)
(box (string->number (extract-binding/single 'idx bindings)))
START-PAGE-ADDRESS))
(args (append
bindings-assoc
(list
(list 'entry addr)
(list 'address addr)
(list 'depth 9)))))
(cond ((exists-binding? 'create bindings)
(response/xexpr
(apply READ-2-HTML-FUN (append (list (list 'entry (apply CREATE-FUN args))) args))))
((exists-binding? 'new_code bindings)
(begin (apply MODIFY-FUN args)
(display (string-append "Modified: " (number->string (unbox addr))))
(response/xexpr (apply READ-2-HTML-FUN args))))
((exists-binding? 'read bindings)
(response/text (pretty-format (apply READ-FUN args))))
((exists-binding? 'examine bindings)
(response/xexpr (apply READ-2-HTML-FUN args)))
(else
(response/xexpr
#:preamble #"<!DOCTYPE html>"
`(html (head
(link ((rel "stylesheet") (type "text/css") (href "styles.css")))
(link ((rel "stylesheet") (type "text/css") (href "style/zoomooz.css")))
(link ((rel "stylesheet") (type "text/css") (href "jqu/css/ui-lightness/jquery-ui-1.8.18.custom.css")))
(script ((type "text/javascript") (src "lib/sylvester.js")) "")
(script ((type "text/javascript") (src "lib/jquery-1.4.4.js")) "")
(script ((type "text/javascript") (src "js/purecssmatrix.js")) "")
(script ((type "text/javascript") (src "js/jquery.animtrans.js")) "")
(script ((type "text/javascript") (src "js/jquery.zoomooz.js")) "")
(script ((type "text/javascript") (src "js/jquery.ba-hashchange.min.js")) "")
;;(script ((type "text/javascript") (src "js/jquery.autoresize.js")) "")
(script ((type "text/javascript") (src "jqu/js/jquery-ui-1.8.18.custom.min.js")) "")
(script ((type "text/javascript") (src "jqu/js/jquery.ui.touch-punch.min.js")) "")
(script ((type "text/javascript") (src "scripts.js")) "")
(title "DDE"))
(body
(div ((class "outerContainer"))
(div ((class "zoomZone"))
(div ((class "viewport"))
,(apply READ-2-HTML-FUN args)))))
)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; caching aliases and bootstraping
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Only really need to cache handler for now...
(display "Initializing core function cache...")(newline)
;;For speed and convenience the core functions are cached in a hash table.
(define CORE (make-hash))
;;Some aliases for convenience.
(define CREATE-FUN (lambda args (apply (hash-ref CORE 'create) args)))
(define READ-META-FUN (lambda args (apply (hash-ref CORE 'read-meta) args)))
(define READ-FUN (lambda args (apply (hash-ref CORE 'read) args)))
(define EVAL-FUN (lambda args (apply (hash-ref CORE 'eval) args)))
(define READ-2-HTML-FUN (lambda args (apply (hash-ref CORE 'read-2-HTML) args)))
(define MODIFY-FUN (lambda args (apply (hash-ref CORE 'modify) args)))
(define HANDLER-FUN (lambda args (apply (hash-ref CORE 'handler) args)))
;;Just enough namespace stuff to get myself in trouble.
;;see: http://docs.racket-lang.org/guide/eval.html#(part._namespaces)
(define-namespace-anchor a)
(define ns (namespace-anchor->namespace a))
(define CREATE-FUN-ADDRESS ((eval init-create-code ns) (list 'new_code init-create-code)))
(hash-set! CORE 'create (eval init-create-code ns))
(display "Create function cached.")(newline)
(define READ-FUN-ADDRESS (CREATE-FUN (list 'new_code init-read-code)))
(hash-set! CORE 'read (eval init-read-code ns))
(display "Read function cached.")(newline)
(define EVAL-FUN-ADDRESS (CREATE-FUN (list 'new_code init-eval-code)))
(hash-set! CORE 'eval (eval init-eval-code ns))
(display "Eval function cached.")(newline)
(define READ-2-HTML-FUN-ADDRESS (CREATE-FUN (list 'new_code init-read-2-HTML-code)))
(hash-set! CORE 'read-2-HTML (EVAL-FUN (list 'entry READ-2-HTML-FUN-ADDRESS )))
(display "Read to HTML function cached.")(newline)
(define MODIFY-FUN-ADDRESS (CREATE-FUN (list 'new_code init-modify-code)))
(hash-set! CORE 'modify (EVAL-FUN (list 'entry MODIFY-FUN-ADDRESS )))
(define HANDLER-FUN-ADDRESS (CREATE-FUN (list 'new_code init-handler-code)))
(hash-set! CORE 'handler (EVAL-FUN (list 'entry HANDLER-FUN-ADDRESS )))
(display "Cache ready.")(newline)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; non-cached initial code
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define init-comment-code
`(lambda (comment)
(lambda args
`(div ((class "comment"))
,comment
,(apply READ-2-HTML-FUN args)))))
(define COMMENT-FUN-ADDRESS (CREATE-FUN (list 'new_code init-comment-code)))
(define init-label-code
`(lambda (label)
(lambda args
`(div ((class "label"))
(a ((href
,(string-append
"?idx="
(number->string (unbox (if (box? (getarg args 'entry))
(getarg args 'entry)
(getarg args 'address)))))))
,label)))))
(define LABEL-FUN-ADDRESS (CREATE-FUN (list 'new_code init-label-code)))
(define init-core-page
`(meta (unmeta
,(list
(list 'meta CREATE-FUN-ADDRESS (list 'read-2-HTML-function (list LABEL-FUN-ADDRESS "Create function")))
(list 'meta READ-FUN-ADDRESS (list 'read-2-HTML-function (list LABEL-FUN-ADDRESS "Read function")))
(list 'meta READ-2-HTML-FUN-ADDRESS (list 'read-2-HTML-function (list LABEL-FUN-ADDRESS "Read to HTML function")))
(list 'meta MODIFY-FUN-ADDRESS (list 'read-2-HTML-function (list LABEL-FUN-ADDRESS "Modify function")))
(list 'meta HANDLER-FUN-ADDRESS (list 'read-2-HTML-function (list LABEL-FUN-ADDRESS "Handler function")))
))
(read-2-HTML-function
(lambda args
`(div (h2 "Core Functions:")
,(apply READ-2-HTML-FUN args))))))
(define CORE-PAGE-ADDRESS (CREATE-FUN (list 'new_code init-core-page)))
(display "Core page created.")(newline)
(define init-meta-description
`(meta database-description
(read-2-HTML-function
(unmeta (lambda args
(,@'(quasiquote) ;;Nested quasiquote unquoting is wierd
(div
(h1 "Meta-expressions")
(p "Meta-expressions are s-expressions with meta-data attached." (br)
"So far, in this environment meta-data is used for the following purposes:")
(ul (li
(h2 "Defining how code/data is presented and interacted with")
(p #;((class "textblock"))
"Complex code/data can be hidden behind media that descibes it or an interface that controls it."(br)
"Right-click and examine meta-expressions to see their source as well as the code/data they abstract away."(br)
"For example, this text is in a meta-expression. Once you've finished reading, try examining it."))
(li
(h2 "Version Control")
(p #;((class "textblock"))
"When a s-expression is altered it becomes a meta-expression with the previous version of the s-expression attached."(br)
"Users can vote on which code branch is used."(br)
;;It would be cool if some links could create iframes with the content they link to.
(a ((href ,(string-append "?idx=" (number->string (unbox MODIFY-FUN-ADDRESS))))) "The policies and procedures for modifying code")
" are programs that can be altered and voted on."))
(li
(h2 "Creating static elements")
(p #;((class "textblock"))
"Without static data it is possible to subvert the voting procedures by branch branching."(br)
"Branch branching is creating a new branch off a element that a branching meta-expression links to" (br)
"rather than branching off the meta-expression which could have special modification rules."(br)
"Branch branching can be prevented by making the root element of a branch static."(br)
"Plasticity is one of the highest goals of this system so static data is used sparingly." (br)
"It should be possible, but not necessarily easy, to change anything." (br)
"Static data is only able to exist in "
(a ((href ,(string-append "?idx=" (number->string (unbox CORE-PAGE-ADDRESS))))) "the system's core")
" if it is elected at some level above."(br)
)))
)))))))
(define META-DESCRIPTION-ADDRESS
(CREATE-FUN (list 'new_code init-meta-description)))
(define init-database-description
`(meta database-description
(read-2-HTML-function
(unmeta (lambda args
(,@'(quasiquote)
(div ((class "grouped_elements"))
(img ((src "lambda_dgraph.png") (class "leftfloat") (alt "graph of s-expressions")))
(p ((class "textblock"))
"There is a database that stores the core code/data of this system." (br);;TODO link
"The code/data is composed of s-expressions, "
(a ((href ,(string-append "?idx=" (number->string (unbox META-DESCRIPTION-ADDRESS))))) "meta-expressions")
" and primatives." (br);;TODO mexp
"Every element can be refrenced by a unique numerical address." (br)
"You can view them by adding a \"?idx=address\" attribute to this site's url." (br)
"S-expressions are essentially a list of links to other elements." (br)
"You can visualize the database as a directed graph. (pictured)" (br)
"Note that cyclic links are possible." (br)
"With the exception of some meta-expressions, every element can be modified." (br)
"When this happens the system changes.")
;;TODO: link to the algorithm, maybe it also describes database
;(p "The meta-expression links to the modified element and the previous version is stored as meta-data.") move up
)))))))
(define DATABASE-DESCRIPTION-ADDRESS
(CREATE-FUN (list 'new_code init-database-description)))
(display "Database description created.")(newline)
(define init-overview
`(if (not (understand? you lisp))
(watch! (meta (unmeta "Abelson and Sussman's Structure and Interpretation of Computer Programs:")
(read-2-HTML-function
(unmeta (lambda args
`(div ,(apply READ-2-HTML-FUN args) (br)
(a ((href "http://www.youtube.com/embed/2Op3QLzMgSY") (target "_blank"))
(img ((src "http://img.youtube.com/vi/2Op3QLzMgSY/0.jpg") (alt "youtube SICP frame"))))))))))
,DATABASE-DESCRIPTION-ADDRESS))
(define OVERVIEW-ADDRESS
(CREATE-FUN (list 'new_code init-overview)))
(display "Overview created.")(newline)
(define init-start-page
`(meta
(unmeta
,(list
(list 'meta OVERVIEW-ADDRESS (list 'read-2-HTML-function (list LABEL-FUN-ADDRESS "Overview")))
(list 'meta CORE-PAGE-ADDRESS (list 'read-2-HTML-function (list LABEL-FUN-ADDRESS "Core Functions")))
))
(read-2-HTML-function
(unmeta
(lambda args
`(div (h2 "Democratic Development Environment:")
(p "A collaborative "
(a ((href "http://en.wikipedia.org/wiki/Reflection_(computer_programming")) "reflective")
" programming environment built on "
(a ((href "http://racket-lang.org/")) "Racket"))
,(apply READ-2-HTML-FUN args)
(p "Basics:")
(div ((class "smalltextblock"))
;;(p "If you mouse over certain regions of the blue bubbles, inputs will appear that you can type Racket code into.")
(p "You can commit your code by clicking on the button below the bubble you typed in.")
(p "When you commit code it will be published on this site and it will be rendered in HTML.")
(p "Try it out in the test area below:"))
(div ((style "width:90%;display:inline-block;"))
,(READ-2-HTML-FUN (list 'entry (CREATE-FUN (list 'new_code null)))))
(div ((class "smalltextblock"))
(p "A new test area is created every time this page is refreshed "
"so anything you commit to it will disappear when you refresh the page.")
(p "However it is not gone, every commited bubble has an address where it can be found.")
(p "You can determine a bubble's address from the '+' link above it.")
) (br)
(div ((class "smalltextblock"))
(p "Keep in mind that it is a prototype and thus slow, buggy, and likely to crash.")
(p "Furthermore, there is no backup functionality yet, so if you contribute any code you want to keep" (br)
"please back it up yourself somehow otherwise it will certainly be lost."))
(p "(shift+click to zoom)")
(p (a ((href "https://github.com/nathanathan/Rhizome")) "Seed code"))))))))
(display "Start page created.")(newline)
;;A implementation of the factorial function for testing self-refrencing code.
(define SELF-REFRENCE-ADDRESS
(CREATE-FUN (list 'new_code 'placeholder)))
(define FACTORIAL-FUN-ADDRESS
(CREATE-FUN (list 'new_code
`(lambda (k) (if (zero? k)
1
(* k ,SELF-REFRENCE-ADDRESS))))))
(MODIFY-FUN (list 'address SELF-REFRENCE-ADDRESS) (list 'new_code `(,FACTORIAL-FUN-ADDRESS (- k 1))))
#;(define CYCLE-EVAL-TEST-ADDRESS
(CREATE-FUN (list 'new_code
`(meta cycle-eval-test
(read-2-HTML-function
(lambda args
(number->string (,FACTORIAL-FUN-ADDRESS 5))))))))
(display "Cycle test created.")(newline)
;(define START-PAGE-ADDRESS CYCLE-EVAL-TEST-ADDRESS)
(define START-PAGE-ADDRESS (CREATE-FUN (list 'new_code init-start-page)))
;;TODO Make this reflective.
(define DISPLAY-EVAL (lambda args (apply READ-2-HTML-FUN (cons (list 'entry (apply EVAL-FUN args)) args))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (start request)
(HANDLER-FUN DATABASE request))
(serve/servlet start
#:launch-browser? #f
#:quit? #f
#:listen-ip #f
#:servlet-regexp #rx"/(test)?$"
#:port 80
#:command-line? #t
#:extra-files-paths
(list (build-path (current-directory) "extraFiles"))
)
)
Jump to Line
Something went wrong with that request. Please try again.