Basics of Scheme
Descripción del contenido de la página
Conversión de antiguos programas de BASIC a Scheme para aprender los rudimentos de este lenguaje.
Etiquetas:
3D Plot
; 3D Plot
; Original version in BASIC:
; 3-D Plot (by Mark Bramhall), 1978.
; Creative Computing (Morristown, New Jersey, USA), ca. 1980.
; This version in Scheme (Bigloo):
; Copyright (c) 2025, Marcos Cruz (programandala.net)
; SPDX-License-Identifier: Fair
;
; Written in 2025-11-30/12-03.
;
; Last modified: 20251205T0113+0100.
(module 3d-plot)
(define (move-cursor-home)
(display "\x1B[H"))
(define (clear-screen)
(display "\x1B[2J")
(move-cursor-home))
(define (display-credits)
(display "3D Plot\n\n")
(display "Original version in BASIC:\n")
(display " Creative computing (Morristown, New Jersey, USA), ca. 1980.\n\n")
(display "This version in Scheme (Bigloo)\n")
(display " Copyright (c) 2025, Marcos Cruz (programandala.net)\n")
(display " SPDX-License-Identifier: Fair\n\n")
(display "Press Enter to start the program. ")
(read-line))
(define (a z)
(* 30 (exp (/ (* (- z) z) 100))))
(define (draw)
(define l 0)
(define z 0)
(define y1 0)
(define line-width 56)
(define line (make-string line-width #\space))
(do ((x -30.0 (+ x 1.5))) ((> x 30.0))
(set! l 0)
(set! y1 (* 5 (floor (/ (sqrt (- 900 (* x x))) 5))))
(do ((y y1 (- y 5))) ((< y (- y1)))
(set! z (floor (- (+ 25 (a (sqrt (+ (* x x) (* y y))))) (* 0.7 y))))
(when (> z l)
(set! l z)
(string-set! line (inexact->exact (truncate z)) #\*)))
(display line)
(newline)
(string-fill! line #\space)))
(clear-screen)
(display-credits)
(clear-screen)
(draw)
Bunny
; Bunny
; Original version in BASIC:
; Creative Computing (Morristown, New Jersey, USA), ca. 1980.
; This version in Scheme (Bigloo):
; Copyright (c) 2025, Marcos Cruz (programandala.net)
; SPDX-License-Identifier: Fair
;
; Written on 2025-12-04.
;
; Last modified 20251224T1229+0100.
(module bunny)
(define (move-cursor-home)
(display "\x1B[H"))
(define (clear-screen)
(display "\x1B[2J")
(move-cursor-home))
(define (print-credits)
(display "Bunny\n\n")
(display "Original version in BASIC:\n")
(display " Creative Computing (Morristown, New Jersey, USA), 1978.\n\n")
(display "This version in Scheme (Bigloo):\n")
(display " Copyright (c) 2025, Marcos Cruz (programandala.net)\n")
(display " SPDX-License-Identifier: Fair\n\n")
(display "Press Enter to start the program.\n")
(read-line))
(define WIDTH 53)
(define line (make-string WIDTH #\space))
(define letters (list #\B #\U #\N #\N #\Y))
(define EOL 127) ; end of line identifier
(define DATA (list
1 2 EOL 0 2 45 50 EOL 0 5 43 52 EOL 0 7 41 52 EOL
1 9 37 50 EOL 2 11 36 50 EOL 3 13 34 49 EOL 4 14
32 48 EOL 5 15 31 47 EOL 6 16 30 45 EOL 7 17 29 44
EOL 8 19 28 43 EOL 9 20 27 41 EOL 10 21 26 40 EOL
11 22 25 38 EOL 12 22 24 36 EOL 13 34 EOL 14 33 EOL
15 31 EOL 17 29 EOL 18 27 EOL 19 26 EOL 16 28 EOL
13 30 EOL 11 31 EOL 10 32 EOL 8 33 EOL 7 34 EOL 6
13 16 34 EOL 5 12 16 35 EOL 4 12 16 35 EOL 3 12 15
35 EOL 2 35 EOL 1 35 EOL 2 34 EOL 3 34 EOL 4 33
EOL 6 33 EOL 10 32 34 34 EOL 14 17 19 25 28 31 35
35 EOL 15 19 23 30 36 36 EOL 14 18 21 21 24 30 37 37
EOL 13 18 23 29 33 38 EOL 12 29 31 33 EOL 11 13 17
17 19 19 22 22 24 31 EOL 10 11 17 18 22 22 24 24 29
29 EOL 22 23 26 29 EOL 27 29 EOL 28 29 EOL))
(define (string-with-replaced-char s position new-char)
(call-with-output-string
(lambda (out)
(display (substring s 0 position) out)
(display new-char out)
(display (substring s (+ position 1) (string-length s)) out))))
(define (letter column)
(list-ref letters (modulo column (length letters))))
(define (display-line)
(display line)
(newline)
(string-fill! line #\space))
(define (draw)
(let loop ((data-index 0))
(let ((first-column (list-ref DATA data-index)))
(if (= first-column EOL)
(display-line)
(begin
(set! data-index (+ data-index 1))
(let ((last-column (list-ref DATA data-index)))
(do ((column first-column (+ column 1))) ((>= column (+ last-column 1)))
(set! line (string-with-replaced-char line column (letter column)))))))
(when (< data-index (- (length DATA) 1))
(loop (+ data-index 1))))))
(clear-screen)
(print-credits)
(clear-screen)
(draw)
Diamond
; Diamond
; Original version in BASIC:
; Example included in Vintage BASIC 1.0.3.
; http://www.vintage-basic.net
; This version in Scheme (Bigloo):
; Copyright (c) 2024, 2025, Marcos Cruz (programandala.net)
; SPDX-License-Identifier: Fair
;
; Written on 2024-12-06, 2025-11-29/30.
;
; Last modified 20251205T0113+0100.
(module diamond)
(define lines 17)
(do ((i 1 (+ i 1)))
((> i (+ (/ lines 2) 1)))
(do ((j 1 (+ j 1)))
((> j (+ (- (/ (+ lines 1) 2) i) 1)))
(display " "))
(do ((j 1 (+ j 1)))
((> j (- (* i 2) 1)))
(display "*"))
(newline))
(do ((i 1 (+ i 1)))
((>= i (/ lines 2)))
(do ((j 1 (+ j 1)))
((> j (+ i 1)))
(display " "))
(do ((j 1 (+ j 1)))
((> j (- (* (- (/ (+ lines 1) 2) i) 2) 1)))
(display "*"))
(newline))
Math
; Math
; Original version in BASIC:
; Example included in Vintage BASIC 1.0.3.
; http://www.vintage-basic.net
; This version in Scheme (Bigloo):
; Copyright (c) 2025, Marcos Cruz (programandala.net)
; SPDX-License-Identifier: Fair
;
; Written on 2025-12-04.
;
; Last modified 20251224T1230+0100.
(module math)
(define (accept-string prompt)
(display prompt)
(read-line))
(define (accept-number prompt)
(let ((input (accept-string prompt)))
(let ((number (string->number input)))
(if number
number
(begin
(display "Number expected.")
(newline)
(accept-number prompt))))))
(define (show basic-function scheme-procedure n result)
(display
(format "~a(~d) -> (~a ~d) -> ~d" basic-function n scheme-procedure n result))
(newline))
(define (sign n)
(cond
((< n 0) -1)
((> n 0) 1)
(else 0)))
(define n (accept-number "Enter a number: "))
(show "ABS" "abs" n (abs n))
(show "ATN" "atan" n (atan n))
(show "COS" "cos" n (cos n))
(show "EXP" "exp" n (exp n))
(show "INT" "truncate" n (truncate n))
(show "LOG" "log" n (log n))
(show "SGN" "ad-hoc:sign" n (sign n))
(show "SQR" "sqrt" n (sqrt n))
(show "TAN" "tan" n (tan n))
Name
; Name
; Original version in BASIC:
; Example included in Vintage BASIC 1.0.3.
; http://www.vintage-basic.net
; This version in Scheme (Bigloo):
; Copyright (c) 2025, Marcos Cruz (programandala.net)
; SPDX-License-Identifier: Fair
;
; Written in 2025-12-03/04.
;
; Last modified 20251224T1231+0100.
(module name)
(define (accept-string prompt)
(display prompt)
(read-line))
(define (accept-integer prompt)
(let ((input (accept-string prompt)))
(let ((number (string->number input)))
(if number
(truncate number)
(begin
(display "Number expected.")
(newline)
(accept-integer prompt))))))
(let ((name (accept-string "What is your name? ")))
(let ((times (accept-integer "Enter a number: ")))
(do ((i 0 (+ i 1))) ((>= i times))
(display (format "Hello, ~a!" name))
(newline))))
Sine Wave
; Sine Wave
; Original version in BASIC:
; Anonymous, 1978.
; Creative Computing's BASIC Games.
; - https://www.atariarchives.org/basicgames/showpage.php?page=146
; - http://vintage-basic.net/games.html
; - http://vintage-basic.net/bcg/sinewave.bas
; - http://www.retroarchive.org/cpm/games/ccgames.zip
; This version in Scheme (Bigloo):
; Copyright (c) 2025, Marcos Cruz (programandala.net)
; SPDX-License-Identifier: Fair
;
; Written in 2025-12-02/03.
;
; Last modified 20251223T1811+0100.
(module sine-wave)
(define (move-cursor-home)
(display "\x1B[H"))
(define (clear-screen)
(display "\x1B[2J")
(move-cursor-home))
(define (display-credits)
(clear-screen)
(display "Sine Wave\n\n")
(display "Original version in BASIC:\n")
(display " Creative Computing (Morristown, New Jersey, USA), ca. 1980.\n\n")
(display "This version in Scheme (Bigloo):\n")
(display " Copyright (c) 2025, Marcos Cruz (programandala.net)\n")
(display " SPDX-License-Identifier: Fair\n\n")
(display "Press Enter to start the program. ")
(read-line))
(define word (vector "" ""))
(define (get-words)
(define order (vector "first" "second"))
(clear-screen)
(do ((w 0 (+ w 1))) ((>= w 2))
(display (format "Enter the ~a word: " (vector-ref order w)))
(vector-set! word w (read-line))))
(define (boolean->integer b)
(cadr (assq b '((#t 1) (#f 0)))))
(define (exact-floor n)
(inexact->exact (truncate n)))
(define (draw)
(let ((even #f))
(do ((a 0.0 (+ a 0.25))) ((>= a 40.25))
(display (make-string (exact-floor (+ (* (sin a) 25) 26)) #\space))
(display (vector-ref word (boolean->integer even)))
(newline)
(set! even (not even)))))
(clear-screen)
(display-credits)
(get-words)
(newline)
(draw)
Stars
; Stars
; Original version in BASIC:
; Example included in Vintage BASIC 1.0.3.
; http://www.vintage-basic.net
; This version in Scheme (Bigloo):
; Copyright (c) 2025, Marcos Cruz (programandala.net)
; SPDX-License-Identifier: Fair
;
; Written on 2025-12-04.
;
; Last modified 20251224T1231+0100.
(module stars)
(define (accept-string prompt)
(display prompt)
(read-line))
(define (accept-integer prompt)
(let ((input (accept-string prompt)))
(let ((number (string->number input)))
(if number
(truncate number)
(begin
(display "Number expected.")
(newline)
(accept-integer prompt))))))
(define (first x) (car x))
(define (rest x) (cdr x))
(define (string-in-list-ci? a-string a-list)
(cond
((null? a-list) #f)
((string-ci=? a-string (first a-list)) #t)
(else (string-in-list-ci? a-string (rest a-list)))))
(define (yes? prompt)
(let ((input (accept-string prompt)))
(string-in-list-ci? input (list "ok" "y" "yeah" "yes"))))
(let ((name (accept-string "What is your name? ")))
(display "Hello, ")
(display name)
(display ".")
(newline))
(define (run)
(let ((number (accept-integer "How many stars do you want? ")))
(display (make-string number #\*))
(newline))
(when (yes? "Do you want more stars? ")
(run)))
(run)
Strings
; Strings
; Original version in BASIC:
; Example included in Vintage BASIC 1.0.3.
; http://www.vintage-basic.net
; This version in Scheme (Bigloo):
; Copyright (c) 2025, Marcos Cruz (programandala.net)
; SPDX-License-Identifier: Fair
;
; Written on 2025-12-05.
;
; Last modified 20251224T1216+0100.
(module strings)
(define (accept-string prompt)
(display prompt)
(read-line))
(define (accept-integer prompt)
(let ((input (accept-string prompt)))
(let ((number (string->number input)))
(if number
(truncate number)
(begin
(display "Number expected.")
(newline)
(accept-integer prompt))))))
(define s (accept-string "Enter a string: "))
(define n (accept-integer "Enter a number: "))
(display
(format
"ASC(\"~s\") --> (char->integer (car (string->list \"~s\"))) --> ~d\n"
s s (char->integer (car (string->list s)))))
(display
(format
"CHR$(~d) --> (integer->char ~d) --> \"~s\"\n"
n n (integer->char n)))
(display
(format
"LEFT$(\"~s\", ~d) --> (substring \"~s\" 0 ~d) --> \"~s\"\n"
s n s n (substring s 0 n)))
(display
(format
"MID$(\"~s\", ~d) --> (substring \"~s\" (- ~d 1)) --> \"~s\"\n"
s n s n (substring s (- n 1))))
(display
(format
"MID$(\"~s\", ~d, 3) --> (substring \"~s\" (- ~d 1) (+ (- ~d 1 ) 3)) --> \"~s\"\n"
s n s n n (substring s (- n 1) (+ (- n 1) 3))))
(display
(format
"RIGHT$(\"~s\", ~d) --> (substring \"~s\" (- (string-length \"~s\") ~d)) --> \"~s\"\n"
s n s s n (substring s (- (string-length s) n))))
(display
(format
"LEN(\"~s\") --> (string-length \"~s\") --> ~d\n"
s s (string-length s)))
(display
(format
"VAL(\"~s\") --> (or (string->number \"~s\") 0) --> ~d\n"
s s (or (string->number s) 0)))
(display
(format
"STR$(~d) --> (number->string ~d) --> \"~s\"\n"
n n (number->string n)))
(display
(format
"SPC(~d) --> (make-string ~d #\\space) --> \"~s\"\n"
n n (make-string n #\space)))