Scheme experiment
/**
* Copyright yonatan ( http://wonderfl.net/user/yonatan )
* MIT License ( http://www.opensource.org/licenses/mit-license.php )
* Downloaded from: http://wonderfl.net/c/qKEA
*/
package {
import flash.display.Sprite;
import flash.utils.getDefinitionByName;
import com.bit101.components.*;
public class Main extends Sprite {
public function Main() {
// an import statement is not enough to make mxmlc include the bytecode for a class!
com.bit101.components.Window;
com.bit101.components.PushButton;
com.bit101.components.Text;
toplevel["*stage*"] = stage;
var expr:* = readString( ( <![CDATA[
(begin
(define add
(lambda (parent child) ((get parent "addChild") child)))
;; draw some stuff
(define map
(lambda (f lst)
(if lst
(cons (f (car lst)) (map f (cdr lst)))
lst)))
(define for-each
(lambda (f lst)
(if lst
(begin
(f (car lst))
(for-each f (cdr lst)))
lst)))
(define rnd
(get Math "random"))
(define rnd-color
(lambda ()
(* 0xffffff (rnd))))
(define make-gradient
(lambda ()
((lambda (s)
((lambda (g)
((get g "beginGradientFill")
"radial"
(new Array (rnd-color) (rnd-color))
(new Array 1 1)
(new Array 0 255)
(quote ())
"reflect"
)
((get g "drawRect") -500 -500 1000 1000)
((get g "endFill")))
(get s "graphics"))
(set! s "blendMode" "difference")
s)
(add *stage* (new flash.display.Sprite)))
))
(define make-floater
(lambda (x y sprite)
(cons x (cons y (cons sprite (quote ()))))))
(define floater-x (lambda (f) (car f)))
(define floater-y (lambda (f) (car (cdr f))))
(define floater-sprite (lambda (f) (car (cdr (cdr f)))))
(define make-floaters
(lambda (n)
(if (= n 0)
(quote ())
(cons
(make-floater (* (rnd) 500) (* (rnd) 500) (make-gradient))
(make-floaters (- n 1))))))
(define floaters (make-floaters 3))
(define abs (get Math "abs"))
(define step
(lambda (n)
(+ 1 (if (> n 500) (- 0 n) n))))
(define move
(lambda (floater)
(set! (floater-sprite floater) "x" (abs (floater-x floater)))
(set! (floater-sprite floater) "y" (abs (floater-y floater)))
(make-floater
(step (floater-x floater))
(step (floater-y floater))
(floater-sprite floater))))
(define frame
(lambda ()
(define floaters (map move floaters))))
((get *stage* "addEventListener") "enterFrame" frame)
;; create the REPL
(define win (new com.bit101.components.Window *stage* 120 120 "REPL"))
(set! win "width" 300)
(set! win "height" 300)
(set! win "alpha" 0.8)
(add *stage* win)
(define input (new com.bit101.components.Text win 0 20 "input"))
(set! input "width" 300)
(set! input "height" 195)
(define output (new com.bit101.components.Text win 0 220 "output"))
(set! output "width" 300)
(set! output "height" 60)
;;(set! output "editable" false)
;; (set! input "text" debugOutput)
(set! input "text" demoCode)
(define println
(lambda (s)
(set! output "text" (str (get output "text") s "
"))))
(define clear-output
(lambda ()
(set! output "text" "")))
(define click-handler
(lambda ()
(clear-output)
(println (eval (read-string (get input "text"))))
(add *stage* win)))
(define btn (new com.bit101.components.PushButton win 200 280 "Eval" click-handler))
)
]]> ).toString() );
eval.call( toplevel, expr );
}
}
}
var demoCode:String =
<![CDATA[;; code goes here...
;; the (begin ...) form is not implied like in most schemes.
(begin
;; this stops the background from moving
((get *stage* "removeEventListener") "enterFrame" frame)
;; function to print lists
(define print-list
(lambda (lst)
(if lst
(begin
(println (car lst))
(print-list (cdr lst)))
"end")))
;; this prints a list of numbers
(print-list (quote (1 2 3))))
]]>;
var toplevel:Object = {
trace: trace,
"get": _get,
"set!": _set,
"new": _new,
"true": true,
"false": false,
"=": eq,
"+": add,
"-": subtract,
"*": multiply,
"/": divide,
"<": function(x:Number, y:Number):Boolean { return x < y },
">": function(x:Number, y:Number):Boolean { return x > y },
"<=": function(x:Number, y:Number):Boolean { return x <= y },
">=": function(x:Number, y:Number):Boolean { return x >= y },
str: str,
"read-string": readString,
eval: eval,
cons: cons,
car: car,
cdr: cdr,
caar: caar,
cadr: cadr,
cdar: cdar,
cddr: cddr,
debugOutput: "debug output:\n",
demoCode: demoCode,
// special forms:
lambda: lambda,
quote: quote,
begin: begin,
"if": _if,
define: define
}
var debugOutput:String = "dsfadf";
function debug( msg:* ):void {
//toplevel["debugOutput"] += msg.toString() + "\n";
//trace( msg.toString() );
}
class Pair {
public var car:*;
public var cdr:*;
public function Pair( x:*, y:* ) {
car = x;
cdr = y;
}
public function toString():String {
return( "(" + (car ? car.toString() : "null") + " . " + (cdr ? cdr.toString() : "null") + ")" );
}
}
class Symbol {
public var name:String;
public function Symbol( name:String ) {
this.name = name;
}
public function toString():String {
return "Symbol: " + name;
}
}
function readString( s:String ):* {
var tokens:Array = tokenize(s);
return parse( tokens );
}
function parse( tokens:Array ):* {
if( tokens.length == 0 ) return null;
var token:String = tokens.pop();
debug( "token: " + token );
// list parser
if( token == ")" ) {
var next:*;
var ret:Pair = null;
while( tokens.length ) {
next = parse( tokens );
if( next is Symbol && next.name == "(" ) return ret;
ret = cons( next, ret )
}
throw "Unbalanced parentheses";
}
// string parser
var first:String = token.substr(0,1);
if( first == '"' ) {
if( first == token.substr( token.length-1, 1 ) ) {
return token.substr( 1, token.length - 2 );
} else {
throw "Unterminated string: " + token;
}
}
// float parser
if( token.indexOf( "." ) != -1 ) {
n = parseFloat( token );
if( !isNaN( n ) ) return n;
}
// integer parser (separate, cause parseFloat screws up hex numbers)
var n:Number = parseInt( token );
if( !isNaN( n ) ) return n;
// symbol parser
return new Symbol(token);
}
// tokenizer from http://www.bluishcoder.co.nz/jsscheme/
// todo: figure out how this shit works and remove unneccesary tokens
// todo: figure out why quote char gets ignored
function tokenize(txt:String):Array {
var tokens:Array = new Array(), oldTxt:String=null;
while( txt != "" && oldTxt != txt ) {
oldTxt = txt;
txt = txt.replace( /^\s*(;[^\r\n]*(\r|\n|$)|#\\[^\w]|#?(\(|\[|{)|\)|\]|}|\'|`|,@|,|\"(\\(.|$)|[^\"\\])*(\"|$)|[^\s()\[\]{}]+)/,
function($0:*,$1:*, ...rest):String {
if( $1.charAt(0) != ';' ) tokens[tokens.length]=$1;
return "";
} );
}
return tokens;
}
function eval( expr:* ):* {
debug( "eval: " + expr.toString() );
if( expr == null ) return null;
var specials:Array = [lambda, quote, begin, define, _if]
if( expr is Pair ) {
var fn:Function = eval.call(this, car(expr));
if( specials.indexOf(fn) != -1 ) { // special form?
return fn.call(this, cdr(expr));
} else { // application
var args:Array = [];
debug( "application: " + expr );
while( expr = cdr(expr) ) {
args.push( eval.call(this, car(expr)) );
}
debug(fn);
return fn.apply( this, args );
}
}
if( expr is Symbol ) {
var value:*;
var env:* = this;
// lookup
debug( "looking up " + expr.name );
while( env[expr.name] === undefined && env.prevEnv ) {
debug( "trying parent environment" );
env = env.prevEnv;
}
if( env[expr.name] === undefined ) { // not found - fall back to getDefinitionByName
value = flash.utils.getDefinitionByName( expr.name );
} else {
value = env[expr.name];
}
debug( "lookup result: " + expr.name + " = " + value );
return value;
}
return expr;
}
function lambda( args:Pair ):Function {
var varNames:Pair = car(args);
var body:Pair = cdr(args);
debug("lambda - args:" + args);
debug("lambda - vars:" + varNames);
debug("lambda - body:" + body);
var that:Object = this;
return function( ...args ):* {
debug( "lambda execution" );
var vars:Pair = varNames; // can't change varNames, cause of future calls to this function
var env:Object = { prevEnv: that };
while( vars ) {
var name:String = car(vars).name;
var value:* = args.shift();
debug( "bind: " + name + " = " + value );
env[name] = value;
vars = cdr(vars);
}
return eval.call( env, cons(begin, body) );
}
}
// create or change a binding in the top level environment
function define( args:Pair ):void {
debug( "define: " + car(args) );
var name:String = car(args).name;
var valueExpr:* = cadr(args);
toplevel[name] = eval.call( this, valueExpr );
}
function quote( arg:* ):* {
return car(arg);
}
// evaluates multiple forms, returns the result of the last evaluation
function begin( forms:Pair ):* {
var ret:*;
while( forms ) {
ret = eval.call( this, car(forms) );
forms = cdr( forms );
}
return ret;
}
function _new( klass:Class, ...a ):* {
debug( "_new: " + klass + " " + a.length + " args" );
switch( a.length ) { // ugly, i know
case 0: return new klass;
case 1: return new klass(a[0]);
case 2: return new klass(a[0],a[1]);
case 3: return new klass(a[0],a[1],a[2]);
case 4: return new klass(a[0],a[1],a[2],a[3]);
case 5: return new klass(a[0],a[1],a[2],a[3],a[4]);
case 6: return new klass(a[0],a[1],a[2],a[3],a[4],a[5]);
case 7: return new klass(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
case 8: return new klass(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
case 9: return new klass(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
case 9: return new klass(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
default: throw "Too many argument for constructor";
}
}
function _if( args:Pair ):* {
var pred:* = eval.call( this, car(args) );
if( pred ) {
return eval.call( this, cadr(args) );
} else {
return eval.call( this, car(cddr(args)) );
}
}
function eq( x:*, y:* ):Boolean {
return( x == y );
}
function add( ...args ):Number {
var ret:Number = 0;
while( args.length ) ret += args.pop();
return ret;
}
function multiply( ...args ):Number {
var ret:Number = 1;
while( args.length ) ret *= args.pop();
return ret;
}
function subtract( x:Number, y:Number ):Number {
return x - y;
}
function divide( x:Number, y:Number ):Number {
return x / y;
}
function str( ...args ):String {
var ret:String = "";
while( args.length ) ret += args.shift().toString();
return ret;
}
// returns an object's property
function _get( obj:*, propName:String ):* {
return( obj[propName] );
}
// sets a property on an object
function _set( target:*, propName:String, value:* ):void {
target[propName] = eval.call( this, value );
}
function cons( x:*, y:* ):Pair {
return new Pair( x, y );
}
function car( p:Pair ):* {
return p.car;
}
function cdr( p:Pair ):* {
return p.cdr;
}
function caar( x:* ):* { return car( car( x ) ) }
function cadr( x:* ):* { return car( cdr( x ) ) }
function cdar( x:* ):* { return cdr( car( x ) ) }
function cddr( x:* ):* { return cdr( cdr( x ) ) }