;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; V-ATTRACTION ;;; ;;; V-ATTRACTION ;;; A number of attractive/repulsive balls. ;;; Also by pz@mit.edu. ;;; Copyright (C) 1988, 1989, 2000 by John S. Pezaris. All rights reserved. ;;; ;;; Changed to Van Der Walls force. (define *graphics-device* '()) (define *graphics-scale* 1000) (define *pi* 3.14159263) (define *n-orbs* 5) (define *default-mass* 400) (define *default-size* 0.02) (define *gravity-threshold* 100) (define *viscoscity-limit* 10) ;;; make-orb ;;; ;;; Constructor for our orbs. An orb will be a tagged list of values. (define (make-orb x-pos y-pos x-vel y-vel x-acc y-acc mass size) (list 'orb x-pos y-pos x-vel y-vel x-acc y-acc mass size)) ;;; orb selectors ;;; ;;; Allows us to pull out each of the component values. (define (orb-x-pxl o) (/ (list-ref o 1) *graphics-scale*)) (define (orb-y-pxl o) (/ (list-ref o 2) *graphics-scale*)) (define (orb-x-pos o) (list-ref o 1)) (define (orb-y-pos o) (list-ref o 2)) (define (orb-x-vel o) (list-ref o 3)) (define (orb-y-vel o) (list-ref o 4)) (define (orb-x-acc o) (list-ref o 5)) (define (orb-y-acc o) (list-ref o 6)) (define (orb-mass o) (list-ref o 7)) (define (orb-size o) (list-ref o 8)) ;;; orb-distance ;;; ;;; Compute the distance between two orbs. Uses the ;;; normal Cartesian formula. (define (orb-distance o1 o2) (sqrt (+ (square (- (orb-x-pos o2) (orb-x-pos o1))) (square (- (orb-y-pos o2) (orb-y-pos o1)))))) ;;; orb-angle ;;; ;;; Computes the angle between two orbs. (define (orb-angle o1 o2) (atan (- (orb-y-pos o2) (orb-y-pos o1)) (- (orb-x-pos o2) (orb-x-pos o1)))) ;;; orb-force-van-der-walls ;;; ;;; Computes the force between two orbs as a modified Van Der Walls force. (define (orb-force-van-der-walls op o1 o2) (let* ((dist (orb-distance o1 o2)) (dist^2 (square dist)) (dist^4 (square dist^2)) (force (* (op (orb-angle o1 o2)) (orb-mass o2)))) (- (/ force dist^2) (* 1.0 (/ force dist^4))))) ;;; orb-force-pseudo-gravity ;;; ;;; Computes the force between two orbs as a modified gravitational attraction. (define (orb-force-pseudo-gravity op o1 o2) (let* ((dist (orb-distance o1 o2)) (dist^2 (square dist)) (projected-force (/ (* (op (orb-angle o1 o2)) (orb-mass o2)) dist^2))) (if (< dist *gravity-threshold*) (- projected-force) projected-force))) ;;; orb-wrap ;;; ;;; Make world toroidal by wrapping excursions beoynd the ;;; limits to the opposite side. (define (orb-wrap pos limit) (cond ((< limit pos) (- pos (* 2 limit))) ((< pos (- limit)) (+ pos (* 2 limit))) (else pos))) ;;; orb-reflect ;;; ;;; Reflects the velocity if the position is at a limit. (define (orb-reflect pos vel limit) (cond ((<= limit pos) (- vel)) ((<= pos (- limit)) (- vel)) (else vel))) ;;; orb-viscoscity ;;; ;;; Limits the acceleration if velocity is excessive. (define (orb-viscoscity acc vel limit) (cond ((<= limit vel) (* 0.9 acc)) ((<= vel (- limit)) (* 0.9 acc)) (else acc))) (define *old-orbs* '()) (define *new-orbs* '()) ;;; enumerate-list ;;; ;;; Returns an enumerated list of the numbers from N to 1. (define (enumerate-list n) (cond ((= n 0) nil) (else (cons n (enumerate-list (dec n)))))) ;;; accumulate ;;; (define (accumulate op null-val lst) (cond ((null? lst) null-val) (else (op (car lst) (accumulate op null-val (cdr lst)))))) ;;; filter ;;; (define (filter op lst) (cond ((null? lst) nil) ((op (car lst)) (cons (car lst) (filter op (cdr lst)))) (else (filter op (cdr lst))))) ;;; maxmin ;;; ;;; Bound the input to an absolute-value specified range. (define (maxmin limit x) (max (- limit) (min limit x))) ;;; attraction ;;; ;;; The main function. (define (attraction . args) ;; Throw some switches to start, selecting the particular flavor ;; of ATTRACTION. (let ((force (if (pair? args) (car args) orb-force-pseudo-gravity)) (wrap (lambda (x y) x)) ; orb-wrap (reflect orb-reflect) (viscoscity orb-viscoscity)) ;; simulation-iterator ;; (define (simulation-iterator n) (if (<= n 0) #t (begin ;; perform a simulation step (set! *new-orbs* (map (lambda (o_i) (let* ((other-orbs (filter (lambda (o_j) (not (eq? o_i o_j))) *old-orbs*)) (x-pos (+ (orb-x-pos o_i) (orb-x-vel o_i))) (y-pos (+ (orb-y-pos o_i) (orb-y-vel o_i))) (x-vel (+ (orb-x-vel o_i) (orb-x-acc o_i))) (y-vel (+ (orb-y-vel o_i) (orb-y-acc o_i))) (x-acc (accumulate (lambda (o_j a) (+ (force cos o_i o_j) a)) 0 other-orbs)) (y-acc (accumulate (lambda (o_j a) (+ (force sin o_i o_j) a)) 0 other-orbs)) ) (make-orb (wrap x-pos *graphics-scale*) (wrap y-pos *graphics-scale*) (reflect x-pos x-vel *graphics-scale*) (reflect y-pos y-vel *graphics-scale*) (viscoscity x-acc x-vel *viscoscity-limit*) (viscoscity y-acc y-vel *viscoscity-limit*) (orb-mass o_i) (orb-size o_i)))) *old-orbs*)) ;; draw the new positions (map (lambda (o_new o_old) (graphics-operation *graphics-device* 'set-foreground-color "white") (graphics-operation *graphics-device* 'draw-arc (orb-x-pxl o_old) (orb-y-pxl o_old) (orb-size o_old) (orb-size o_old) 0 360 #t) (graphics-operation *graphics-device* 'set-foreground-color "blue") (graphics-operation *graphics-device* 'draw-arc (orb-x-pxl o_new) (orb-y-pxl o_new) (orb-size o_new) (orb-size o_new) 0 360 #t)) *new-orbs* *old-orbs*) ;; update (set! *old-orbs* *new-orbs*) ;; iterate (simulation-iterator (dec n))))) ;; insure that we have a window to display things (if (null? *graphics-device*) (set! *graphics-device* (make-graphics-device 'x))) ;; make all of the objects in our simulation (let ((phi (map (lambda (x) (* 2 *pi* (/ (+ 0.5 x) *n-orbs*))) (enumerate-list *n-orbs*)))) (set! *old-orbs* (map (lambda (phi) (let ((mass (max 1 (random *default-mass*)))) (make-orb (+ (/ (random 100) 1000) (* 0.5 *graphics-scale* (cos phi))) (+ (/ (random 100) 1000) (* 0.5 *graphics-scale* (sin phi))) 0 0 0 0 mass (* (sqrt (/ mass *default-mass*)) *default-size*)))) phi))) ;; and run the simulation! (graphics-clear *graphics-device*) (simulation-iterator 10000) ))