POWERPAK.WS4
------------
Joe Power's Dr. Logo programs
Who is Joe Power? When I patched Dr. Logo for CP/M-86 Plus, I also dumped its
LOGOHELP file. At the end, I found the following:
June 29th, 1984
The Wizards: Steve Schmitt, Tim Oren, Joe Power, Gary Kildall
SHIP IT!!!
So, I had the idea to search for its authors. Recently, I had the surprise to
receive a message from Joe Power. Among other things, he told me:
Mr. Roche,
I was searching for something else entirely this evening, when I came
across your request for the Dr. Logo Toolboxes.
It has been many years since I was involved with Dr. Logo, but I did
some rummaging around my code archives and found a collection of most
of the Dr. Logo code I wrote at the time. I have attached it to this
email.
There is almost no documentation included with these files because
most were used in either the one and only issue of the "Dr. Logo
Newsletter" or a never-released set of educational exercises. I have a
printed copy of the newsletter (because I wrote it) but the
consumer/educational division was disbanded before the exercise
package was finished and I doubt anything other than these procedures
survives.
I hope this helps.
Joe Power
So, this is a real treasure that Joe agreed to share with us: more than 60
working programs for the first 16-bit Logo: Dr. Logo. All I had to do was to
try to run them... As Mr. Power explained:
As I recall, when we developed Dr. Logo, the EGA card didn't even
exist (it came out in 1984), let alone the VGA. The CGA supported
resolutions of 640x200 and 320x200. There was a magic value to write
to a port to allow the CGA to display cyan, red and white instead of
cyan, magenta and white (which we put in the .COLOROFF and .COLORON
functions). This is how we could get red, white & blue (by setting the
background color to blue.) This was highly specific to the CGA card's
hardware (and not officially supported by IBM), so subsequent video
cards probably would ignore them.
> By the way, what is the purpose of SP?
>
> to sp :pal
> (local "bg)
> make "bg remainder (first sf) 16
> if :pal > 2 [make "bg :bg + 16 make "pal :pal - 3]
> if :pal > 0 [make "bg :bg + 32]
> if :pal = 2 [.coloroff] [.coloron]
> setbg :bg
> end
In looking at the original "Dr. Logo Command Summary", I see that the
background color (bg) can be set from 0 to 63. This is obviously a
kludge to set both the background color (which can only range from 0
to 15) and the graphics palette at the same time. SP is thus an
abbreviation of SETPAL (which is what IBM Logo used).
What this function does is to set the 320x200 color palette without
disturbing the background color:
PAL Palette
--- -------
0 red, green, yellow
1 cyan, magenta, white
2 cyan, red, white
(You could also use 3, 4 & 5, though I have no idea why you would want
to. Remember that the .COLOROFF function only changes the palette when
using an RGB monitor. When using a composite monitor, it changes the
colors to grayscale.)
> SCREENFACTS only give you a number for the "current resolution setting". So
> the program has no way of knowing the XxY resolution (as far as I can see).
There were only 2 resolutions on the CGA (3 on the PCjr): 640x200 and
320x200 (and 160x100 on the jr.) Those numbers were fixed and could
not be changed.
You can almost derive the mode from the background color. There were
16 possible background colors but the BG function returned a number
from 0 to 63. Take a second look at the SP function I explained and
you should be able to see how bits 4 and 5 (if you treat the
background color as a binary value) indicate the resolution and, in
medium resolution, the palette. The one exception was that
undocumented cyan, red, white palette (set with the .COLOROFF
function).
> How do you time a program under Dr. Logo?
Dr. Logo had no time handling procedures for the simple reason that
IBM PCs came with no real-time clock. (...) At the time we wrote it,
Dr. Logo was slow enough we just used a stopwatch.
I tried a few things, and found a nasty surprise: according to the "Dr. Logo
Reference Manual", Section 1.2.3 Numbers, "Dr. Logo uses two kinds of numbers:
integers and decimal numbers. You can input negative or positive decimal
numbers with up to 15 significant digits, and any integer between 2147483647
and -2147483648."
Unfortunately, while it is sure that Dr. logo uses Double Precision Floating-
Point for its decimal numbers (thus providing up to 15 significant digits),
each time I used integer, I got a 15-bit result (or 32767 to -32768). 32K may
seem perfectly reasonable, except for the fact that the IBM PC is no longer
running at 4-MhZ...
Mr. Power has also written a "Personal History of Dr. Logo" text, that you
will find under the name DRLHIST.
So, it must be well understood that the following Turtle Graphics programs
were programmed in 1984, for a CGA screen. Since I am a beginner in Dr. Logo
programming, I did not manage to run all the programs on my so-called "IBM PC"
with a VGA screen. In particular, each time there were .COLORON and .COLORFF,
the program would not run. Once removed, they worked... So, you could have a
little bit of work to do, to have those programs run on your particular
computer.
Also, do not forget that Dr. Logo uses a "workspace" and that LOG files do not
necessarily correspond to a given program. However, Dr. Logo has a command to
know which "programs" exist in the workspace: POTL. So, after loading a LOG
file, type POTL and see if the file contained only one program, or several. I
found VERALL very useful when erasing no-longer needed subroutines. Don't
forget, too, that there are 2 screen resolutions: SETRES 0 and SETRES 1. When
using the editor, I prefer the 80 column screen.
Happy Dr. Logo programming!
Table of Contents
-----------------
Games
-----
ADV Classic "Adventure" game
ANIMAL Classic animal-guessing game
AUSSIE Traveling in Australia (draw the map)
AUSSIE2 Traveling in Australia 2 (load a picture)
BFLY Enter a b c d e f (mixed) to see the butterfly
CARDS Blackjack
ELIZA Is it a game?
MAZE Maze game
REVERSE Game of Reverse
WEST Railway game
Business Graphics
-----------------
BARCHART Programmed bar chart (not interactive)
BCHART2 Interactive bar chart
CHARTS Line, Pie, and Bar charts
PCHART Pie chart
Graphics
--------
BRAIDS Braids
CP Figure mixing hexagon and octagon
DDD Pseudo 3D with lines
DENNIS Draws the face of "Dennis the Menace"
DESIGN Draws a 5-items image
DISCOVER Draws a Chinese word ("discover")
DRAGON Fractals programs
DRI Draws the Digital Research's logo
DRLOGO Another version
FIGURE Draws an 3D hexagon?
GAGFILL Showed a problem on the EGA screen
HEART Draws three hearts (0.2, 0.35, and 0.5)
KEPLER See explanation
LETTERS Draws (literally) up to 3 names
MTURTLE Demo of multiple turtles (4)
POLAR Draws 4 polar graphs
QBERT 5-level cascade of cubes
ROSE Draws variable-leaves rose
SHAPES Draws 5 drawings
STAR Draws a 5-arms star
STRING Display a ?
STUFF Contains 10 programs...
UJACK Draws the British flag ("Union Jack")
USFLAG Draws the US flag
TARDIS Time Travel Capsule of English TV series "Dr. Who"
THREED 3D Package from "Dr. Logo Newsletter #1"
TOOLS Various useful routines
TOYBOX Various boards routines
TRIG Display SIN and COS values
WEB Display a spider on a web
Maths
-----
DIFF Differential equation solver
Utility
-------
DR2 Procedures emulating some Dr. Logo Version 1 primitives
MERGE Mail merge printing of addresses
NSQRT New square root routine
TELL Tell the various properties of a procedure
TOOLBX1 Improved from the Dr. Logo Newsletter #1
TOOLBX2 Improved from the Dr. Logo Newsletter #1
TOOLBX3 Improved from the Dr. Logo Newsletter #1
TOOLBX4 Improved from the Dr. Logo Newsletter #1
TOOLBX5 Improved from the Dr. Logo Newsletter #1
TOOLBX6 Improved from the Dr. Logo Newsletter #1
LOSHIFT Convert a file to lowercase
UPSHIFT Convert a file to uppercase
POFILE Display contents of a file
UTILITY 4 workspace routines
XDIR Display the directory of a disk
Sound
-----
MUSIC Works on my 100-MHz PC
Words
-----
FRENCH Change the primitives to use French words
POEM Poem generator
POEM2 Another one
To be explained
---------------
PATHS Traveling salesman program, but how to use it?
To be modified
--------------
DRAW Drawing using a joystick (replace by mouse)
What's that?
------------
ROLEPLAY Draws a page listing the characteristics of each player?
Not working?
------------
DYNA Dynaturtle? (How to use it?)
Games
-----
ADV Classic "Adventure" game
to adventure
(local "a "adj "answer "b "c "d "dragon "e "f "g "game.over "h "i "j "noun
"possessions "room "spider "verb "verblist)
init.adventure
until [:game.over] [get.command run :verb]
pr [Play again (Y\/N) ?\ ]
if "y = first rq [adventure]
end
to chest
pu seth 0 setpos [10 38] pd
repeat 2 [fd 10 rt 90 fd 20 rt 90] fd 10
repeat 13 [fd 2.6105 rt 15] seth 180
setx xcor - 10 pu fd 2 pd fd 4
end
to clock
pu setpos [-30 16] seth 0 pd
repeat 24 [fd 2.61 rt 15]
pu setx xcor + 10 pd
fd 9 bk 9 rt 60 fd 6
end
to contents.of :room
op item 6 thing :room
end
to dragon
pu seth 0 setpos [10 20] pd
repeat 5 [fd 8 rt 45]
repeat 11 [fd 4 rt 45]
repeat 9 [fd 4 lt 45]
rt 30 fd 5 bk 5 rt 30 fd 5 bk 5
pu seth 0 setpos [13 22] pd repeat 4 [fd 2 rt 90]
pu setpos [23 22] pd repeat 4 [fd 2 rt 90]
pu seth 0 setpos [10 20] pd
setpos [17 8] setpos [17 3] setpos [23 3]
setpos [23 8] setpos [29.3 20]
dot [19 5] dot [21 5]
end
to draw :room
(local "x "y)
setbg item 4 thing :room
setpc item 3 thing :room
make "x (item 7 (thing :room)) make "y [1 3 2 4]
cs pu setpos [-40 60] seth 90 pd
repeat 4 [
if "0 = item (first :y) :x
[fd 80]
[fd 30 lt 90 fd 10 rt 90 pu fd 20 rt 90 pd fd 10 lt 90 fd 30]
rt 90 make "y bf :y]
run item 6 thing :room
ct
pr item 1 thing :room
if "FALSE = (item 5 thing :room) [stop]
make "x item 2 thing :room
repeat count :x [pr first :x make "x bf :x]
if not emptyp (item 6 thing :room) [(pr [In the room you see:] item 6 thing
:room)]
make :room (se (piece 1 4 thing :room) "FALSE (piece 6 7 thing :room))
end
to drop
if :noun = "dead [pr [Ok, you're dead!] make "game.over "TRUE stop]
if memberp :noun [drawers pants] [pr [I'm not that kind of adventurer!] stop]
if emptyp :possessions [pr [You've nothing to drop but your pants.] stop]
make "possessions remove :possessions :noun
make :room (se (piece 1 5 thing :room) (lput :noun (item 6 thing :room)) (last
thing :room))
draw :room
end
to eat
pr [Yuck! I can't eat that.]
end
to get
if memberp :noun [inventory inv]
[if not emptyp :possessions
[(pr [You are carrying:] :possessions)]
[pr [You aren't carrying anything.]]
stop]
if not memberp :noun (contents.of :room)
[(pr [I don't see the] :noun [here.]) stop]
if :noun = "chest [pr [It won't budge!] stop]
if :noun = "spider
[[pr [The spider eats you!]
[pr [You lose.]
make "game.over "TRUE stop]]]
if :noun = "dragon
[[pr [The dragon sneezes and burns you to a crisp!]
[pr [You lose.]
make "game.over "TRUE stop]]]
make "possessions lput :noun :possessions
make :room remove.from (thing :room) :noun
draw :room
end
to get.command
label "gc
type [Tell me what to do?\ ]
make "answer rl
if 2 <> count :answer
[pr [Sorry, I only know two word commands.] go "gc]
make "verb first :answer
if memberp :verb [grab take snatch] [make "verb "get]
if memberp :verb [kill fight attack] [make "verb "slay]
if memberp :verb [head go] [make "verb "move]
if memberp :verb [examine investigate search] [make "verb "look]
if memberp :verb [throw put] [make "verb "drop]
if :verb = "open [make "verb "unlock]
if not memberp :verb :verblist [make "verb "unknown]
make "verb (se :verb)
make "noun last :answer
end
to init.adventure
setres 1 setsplit 5 ss ht
make "game.over "FALSE
make "verblist [get drop slay unlock move look eat quit]
make "possessions []
make "dragon "alive
make "spider "alive
make "a [[Entrance / Exit] [[This is the room where your adventure] [begins
and ends. Return here when the] [dragon is vanquished to win the game.]] 3 1
TRUE [] [0 b c 0]]
make "b [[Slime room] [[This room oozes and pulsates with] [horrible, slimey
ichor.]] 3 2 TRUE [] [a 0 d 0]]
make "c [[Dusty room] [[This room is several inches deep] [with dust and
debris.]] 3 15 TRUE [] [0 d 0 a]]
make "d [[Green room] [[This room is painted in an awful] [shade of bright
green.]] 3 10 TRUE [sword] [c 0 f b]]
make "e [[Blue room] [[This room is a cheerful blue, marred] [only by a few
bloodstains.]] 3 1 TRUE [key] [0 f g 0]]
make "f [[Mirror room] [[Everyplace you look there are mirrors.] [A person
could get dizzy in here.]] 1 15 TRUE [] [e 0 h d]]
make "g [[Purple room] [[This room was used for grape stomping.] [That's why
the walls are so purple.]] 3 13 TRUE [clock] [0 0 i e]]
make "h [[Web\-covered room] [[You have found the spider's lair!] [Be careful,
or the spider will eat you.]] 3 4 TRUE [spider] [0 0 j f]]
make "i [[The dragon's lair] [[The bones of previous adventurers lay]
[scattered about.]] 2 0 TRUE [dragon] [0 0 0 g]]
make "j [[The gold room] [[This is the fabled room of gold!] [Sadly, you can't
take the walls.]] 2 14 TRUE [chest] [0 0 0 h]]
make "room "a
draw :room
end
to key
pu seth 0 setpos [10 -5] pd
fd 5 rt 90 fd 3 rt 90 fd 5 bk 5 lt 90 fd 12 lt 90 repeat 24 [fd 1.2 rt 15]
end
to look
make :room (se (piece 1 4 thing :room) "TRUE (piece 6 7 thing :room))
draw :room
if not emptyp :possessions
[(pr [You are carrying:] :possessions)]
[pr [You aren't carrying anything.]]
end
to move
if not memberp :noun [north south east west]
[(pr [I can't go] :noun) stop]
make "adj item where (item 7 thing :room)
if memberp "spider (contents.of :room) [pr [The spider blocks the exit.] stop]
if memberp "dragon (contents.of :room) [pr [The dragon guards the door.] stop]
if :adj = "0 [pr [I can't go that way.] stop]
make "room :adj
draw :room
if (and (:room = "a) (:dragon = "dead))
[tones [440 80 554 80 659 80 880 80 0 80 659 80 880 240]
pr [You've won! Congratulations.] make "game.over "TRUE]
end
to quit
pr [Ok, goodbye.]
make "game.over "TRUE
end
to remove :n :object
(local "m)
repeat count :n
[if (first :n) <> :object
[make "m lput (first :n) :m]
make "n bf :n]
op :m
end
to remove.from :objlist :object
(local "n "m)
make "n item 6 :objlist
op (se (piece 1 5 :objlist) (list remove :n :object) (list (last :objlist)))
end
to slay
(local "monster)
make "monster contents.of :room
if memberp "spider :monster [make "monster "spider go "s1]
if memberp "dragon :monster [make "monster "dragon go "s2]
pr [You must find a monster to fight it,]
pr [brave adventurer.] stop
label "s1
if not memberp "sword :possessions
[pr [You have no sword!]
pr [The spider eats you! You lose.]
make "game.over "TRUE stop]
go "s3
label "s2
if not memberp "spray\ can :possessions
[pr [You have no dragon repellent!]
pr [He devours you! You lose.]
make "game.over "TRUE stop]
label "s3
(pr [You vanquish the] :monster [!])
make :monster "dead
make :room remove.from (thing :room) :monster
draw :room
end
to spider
pu setpos [-25 35] seth 0 pd
repeat 3 [setx -30 rt 45 bk 4 fd 4 lt 45 setx -25 fd 5]
setx -30 rt 45 bk 4 fd 4 lt 45 setx -25
rt 30 fd 8 bk 3 rt 120 bk 3 fd 8 rt 30
repeat 3 [setx -15 lt 45 fd 4 bk 4 rt 45 setx -20 fd 5]
setx -15 lt 45 fd 4 bk 4 rt 45 setx -20
rt 30 fd 5 rt 120 fd 5
end
to sword
pu setpos [-15 -5] pd
seth 270 fd 16 rt 45 fd 4 rt 90
fd 4 rt 45 fd 16 lt 90 fd 2 rt 90
repeat 2 [fd 2 rt 90 fd 10 rt 90]
fd 2 rt 90 fd 3 lt 90
repeat 2 [fd 6 rt 90 fd 4 rt 90]
end
to unknown
(pr [I don't know how to] :answer)
end
to unlock
if :noun <> "chest
[pr [Sorry, you can only open chests.] stop]
if not memberp "chest (contents.of :room)
[pr [You can't open what isn't here.] stop]
if not memberp "key :possessions
[pr [You haven't got the key.] stop]
pr [As you open the chest, it vanishes along with the key!]
pr [In its place, there is a can of dragon - repellent which you take.]
make :room remove.from (thing :room) "chest
make "possessions lput "spray\ can (remove "possessions "key)
draw :room
end
to until :cond# :body#
; Perform the body until the condition is TRUE
label "loopst
run :body#
if not run :cond# [go "loopst]
end
ANIMAL Classic animal-guessing game
to question :node
op first :node
end
to no.branch :node
op last :node
end
to extend.knowledge :new.question :yes.answer :no.answer
make "knowledge
replace :knowledge :no.answer
(list :new.question :yes.answer :no.answer)
end
to animal
load.tree
animal2
end
to yes.branch :node
op first (bf :node)
end
to get.smarter :wrong.answer
pr [Oh well, I was wrong. What was it?]
make "right.answer
(last readlist)
pr (se [Please type in a question whose answer is yes for]
add.a.or.an :right.answer [and no for]
add.a.or.an :wrong.answer)
make "question readlist
extend.knowledge
:question :right.answer :wrong.answer
end
to replace :tree :node :replacement
if :tree = :node
[op :replacement]
if wordp :tree
[op :tree]
op (list
question :tree
replace yes.branch :tree :node :replacement
replace no.branch :tree :node :replacement)
end
to ask.yes.or.no :question
pr :question
make "input readlist
if :input = [yes]
[op [yes]]
if :input = [no]
[op [no]]
pr [Please type "yes" or "no"]
op ask.yes.or.no :question
end
to add.a.or.an :word
if memberp (first :word) [a e i o u]
[op se "an :word]
op se "a :word
end
to guess :animal
make "final.question
se [Is it] add.a.or.an :animal
make "response
ask.yes.or.no :final.question
if :response = [yes]
[pr [Look how smart I am.] stop]
get.smarter :animal
end
to choose.branch :node
if (wordp :node)
[guess :node stop]
make "response ask.yes.or.no (question :node)
if :response = [yes]
[choose.branch yes.branch :node stop]
choose.branch (no.branch :node)
end
to save.tree
erasefile :fnbak
changef :fnbak :fn
save :fn "tree
end
to animal2
pr [Think of an animal. I will try to guess it by asking questions.]
choose.branch :knowledge
type [Do you want to save the current knowledge (Y\/N) ?\ ]
if readchar = "y [save.tree]
pr [Let's try again...]
animal2
end
to load.tree
type [Drive letter of program disk, please:\ ]
make "fn word readchar ":tree
make "fnbak word :fn "bak
pr []
load :fn
package "tree "knowledge
end
make "fn "tree
make "fnbak "treebak
AUSSIE Traveling in Australia
to australia :n
(local "p "h)
make "p pos make "h heading pu lt 90 fd 8.5 * :n rt 90 pd
fd 1.5 * :n rt 45 fd 1.414 * :n rt 45 fd 1.5 * :n lt 45
fd 1.414 * :n lt 45 fd 1.5 * :n rt 90 fd :n lt 90
fd 0.5 * :n rt 45 fd 0.707 * :n rt 45 fd 0.5 * :n rt 90
fd 0.5 * :n lt 90 fd :n lt 90 fd 0.5 * :n rt 45
fd 0.707 * :n lt 45 fd 0.5 * :n rt 45 fd 0.707 * :n rt 45
fd 2.5 * :n rt 90 fd 0.5 * :n rt 45 fd 0.707 * :n lt 45
fd 0.5 * :n lt 45 fd 2.121 * :n lt 45 fd 0.5 * :n rt 45
fd 0.707 * :n lt 45 fd 0.5 * :n lt 90 fd 4 * :n rt 90
fd 0.5 * :n rt 90 fd :n lt 45 fd 0.707 * :n lt 45
fd 0.5 * :n rt 90 fd 1.5 * :n lt 45 fd 1.414 * :n rt 45
fd 0.5 * :n lt 90 fd 0.5 * :n rt 90 fd :n lt 90
fd 0.5 * :n rt 90 fd 0.5 * :n lt 90 fd 0.5 * :n rt 45
fd 0.707 * :n rt 45 fd 3.5 * :n rt 90 fd 0.5 * :n lt 90
fd :n rt 90 fd 0.5 * :n lt 90 fd :n rt 90
fd 0.5 * :n lt 90 fd :n rt 45 fd 0.707 * :n rt 45
fd :n lt 45 fd 0.707 * :n rt 90 fd 0.707 * :n lt 90
fd 0.707 * :n rt 90 fd 0.707 * :n rt 45 fd 0.5 * :n lt 45
fd 0.707 * :n lt 45 fd 0.5 * :n rt 90 fd 1.5 * :n lt 135
fd 1.414 * :n rt 90 fd 1.414 * :n rt 45 fd 0.5 * :n lt 90
fd 3 * :n lt 45 fd 2.121 * :n rt 45 fd :n lt 45
fd 1.414 * :n rt 45 fd :n rt 45 fd 0.707 * :n rt 45
fd 0.5 * :n rt 90 fd 0.5 * :n lt 90 fd 0.5 * :n lt 45
fd 0.707 * :n rt 45 fd :n lt 45 fd 0.707 * :n rt 45
fd :n lt 45 fd 0.707 * :n rt 45 pu bk 5 * :n rt 90 fd 10.5 * :n pd
fd :n rt 135 fd 0.707 * :n rt 90 fd 0.707 * :n rt 45 pu
bk 1.5 * :n rt 90 fd 2 * :n pd fd 2 * :n rt 90 fd 1.5 * :n rt 90
fd :n rt 45 fd 0.707 * :n rt 45 fd 0.5 * :n lt 45
fd 0.707 * :n rt 45 pu bk 0.5 * :n rt 90 fd :n pd fill pu
bk 2.5 * :n lt 90 fd 1.8 * :n pd fill pu fd 3 * :n pd fill pu
setpos :p seth :h
end
to border
setpc 4
pu setpos [-155 100] seth 180 pd
repeat 16 [fd 10 lt 90 fd 2 pu bk 2 rt 90 pd] lt 90
repeat 31 [fd 10 lt 90 fd 2 pu bk 2 rt 90 pd] lt 90
repeat 16 [fd 10 lt 90 fd 2 pu bk 2 rt 90 pd] lt 90
repeat 31 [fd 10 lt 90 fd 2 pu bk 2 rt 90 pd]
end
to cities
pu seth 90 textfg 3 setpc 3
setpos [61 0] pd setpc 15 tt char 219 setx 71 fd 7 fd 3 tt [Brisbane] pu
setpos [56 -20] pd setpc 15 tt char 219 setx 61 fd 17 fd 3 tt [Sydney] pu
setpos [26 -33] pd setpc 15 tt char 219 setx 33 fd 45 fd 3 tt [Melbourne] pu
setpos [-89 -10] pd setpc 15 tt char 219 setx -104 fd 10 setx -144 tt [Perth]
pu
setpos [-9 15] pd setpc 15 tt char 219 setx -1 fd 79 fd 3 tt [Ilbunga] pu
setpos [-24 90] pd setpc 15 tt char 219 setx -94 fd 65 setx -144 tt [Darwin]
pu
home textfg 3
end
to cret
textfg 2 type [\ \ \ \ < Press Enter >] make "x rc textfg 3
ct
end
to dist :b
op sqrt ((abs (xcor - (first :b))) ^ 2 + (abs (ycor - (last :b))) ^ 2))
end
to explain_game
(local "x)
ct
pr [You've just won a trip to Australia!] wait 5
pr [Now, you must travel to each of the]
pr [six cities on the map.]
cret ct
pr [There will be six trips to make.]
pr [Each trip, you will give both the]
pr [heading and distance to travel.]
cret ct
pr [You will have 5 chances to arrive]
pr [at your destination\; after that,]
pr [a friendly guide will assist you.]
cret ct
pr [Enjoy your vacation!] pr [] pr []
cret
end
to get_dest_location
if emptyp :places [make "dest :start stop]
make "dest item (1 + random count :places) :places
make "places remove :dest :places
end
to get_distance
(local "q "cmd)
label "loopst
ct
pr [Please move the turtle (ex: fd 30)]
make "cmd rl if :cmd = [quit] [throw "cities]
if not 2 = count :cmd [
pr [I need to know which way to]
pr [move, and how far to go.]
pr [Use Logo commands like fd 113 or bk 34]
cret
go "loopst]
make "q first :cmd
if not (or ("fd = :q) ("forward = :q) ("bk = :q) ("back = :q)) [
pr [I can only move forward or back.]
pr [Remember to use lower case letters.]
cret
go "loopst]
make "q last :cmd
if not numberp :q [
pr [I need a number to tell me]
pr [how far to move.]
cret
go "loopst]
if 1000 < abs :q [
pr [Your plane won't fly that far.]
pr [Please use numbers between]
pr [-1000 and 1000]
cret
go "loopst]
setpc 2 pd run :cmd pu
end
to get_heading
(local "x "q)
label "loopst
ct
(pr [Today, you leave] :src [for] :dest)
pr [Please turn the turtle (ex: rt 30)]
make "x rl if :x = [quit] [throw "cities]
if not 2 = count :x [
pr [I need to know which way to]
pr [turn, and how far to turn.]
pr [Use Logo commands like lt 113 or rt 34]
cret
go "loopst]
make "q first :x
if not (or ("rt = :q) ("right = :q) ("lt = :q) ("left = :q)) [
pr [I can only turn right or left.]
pr [Remember to use lower case letters.]
cret
go "loopst]
make "q last :x
if not numberp :q [
pr [I need a number to tell me]
pr [how far to turn.]
cret
go "loopst]
if 1000 < abs :q [
pr [I'm getting dizzy!]
pr [Please, use numbers between]
pr [-1000 and 1000]
cret
go "loopst]
run :x
end
to get_start_location
make "brisbane [61 0]
make "sydney [56 -20]
make "melbourne [26 -33]
make "perth [-89 -10]
make "ilbunga [-9 15]
make "darwin [-24 90]
make "places [brisbane sydney melbourne perth ilbunga darwin]
make "start item (1 + random 6) :places
make "places remove :start :places
make "src :start
make "turn 0
end
to askyn :question
(local "ans)
label "flush
if keyp [make "ans rc go "flush]
(type :question) make "ans lc rc
(pr :ans) op :ans = "y
end
to play
(local "brisbane "sydney "melbourne "perth "darwin "ilbunga)
(local "places "start "src "dest "turn "x)
setsplit 4 textfg 3
ct splitscreen ht
cs sp 1 setbg 1 setpc 2
pu setpos [-14 20]
australia 10
setpc 3
border
cities
explain_game
get_start_location
catch "cities [
repeat 6 [
get_dest_location
player_moves]]
ct
pr [Thus ends your vacation in Australia.]
(pr [Native guides helped you\ ] :turn [\ time (s) .])
pr [We hope you will come back sometime.]
cret
if askyn [Play again (Y\/N) ?\ ] [play]
end
to player_moves
(local "try)
ct pu setpos thing :src
make "try 1
label "loopst
pu setpos thing :src seth 0 st
get_heading
get_distance
if not (dist thing :dest) > 5 [
make "src :dest
ct (pr [You have arrived at] :dest [!])
pr [Not bad for a yank.]
pr []
cret stop]
ct
if (dist thing :src) < 5 [(pr [You barely left] :src) pr []] [
if (dist :brisbane) < 5 [pr [The Brisbane hotel was closed.] pr []] [
if (dist :sydney) < 5 [pr [The Sydney hotel was closed.] pr []] [
if (dist :melbourne) < 5 [pr [The Melbourne motel was closed.] pr []] [
if (dist :perth) < 5 [pr [The Perth hotel was closed.] pr []] [
if (dist :ilbunga) < 5 [pr [The Ilbunga inn was closed.] pr []] [
if (dist :darwin) < 5 [pr [The Darwin hotel was closed.] pr []] [
pr [Silly tourist! You got lost and you]
(pr [had to fly back to] :src)]]]]]]]
pr []
cret
make "try :try + 1
if :try < 6 [go "loopst]
ct
pr [A friendly native guide helps you.]
seth towards thing :dest
setpos thing :dest
pr []
pr []
cret
make "src :dest
make "turn :turn + 1
end
to remove :object :objlist
if :object = first :objlist [op bf :objlist]
op fput (first :objlist) remove :object bf :objlist
end
to textfg :n
end
to sp :pal
local "bg
make "bg remainder (first sf) 16
if :pal > 2
[make "bg :bg + 16
make "pal :pal - 3]
if :pal = 0
[make "bg :bg + 32]
setbg :bg
end
AUSSIE2 Traveling in Australia 2
to cret
textfg 2 type [\ \ \ \ < Press Enter >] make "x rc textfg 3
ct
end
to dist :b
(local "x "y)
make "x xcor - first :b make "y ycor - last :b
op sqrt (:x * :x + :y * :y)
end
to explain_game
(local "x)
ct
pr [You've just won a trip to Australia!] wait 5
pr [Now, you must travel to each of the]
pr [six cities on the map.]
cret ct
pr [There will be six trips to make.]
pr [Each trip, you will give both the]
pr [heading and distance to travel.]
cret ct
pr [You will have 5 chances to arrive]
pr [at your destination\; after that,]
pr [a friendly guide will assist you.]
cret ct
pr [Enjoy your vacation!] pr [] pr []
cret
end
to get_heading
(local "x "q)
label "loopst
ct (pr [Today, you leave] :src [for] :dest)
pr [Please turn the turtle (ex: rt 30)]
if [] <> :lturn
[(pr [Your last try was:] :lturn)]
make "x rl if lc first :x = "quit [throw "cities]
if 2 <> count :x [
pr [I need to know which way to]
pr [turn, and how far to turn.]
pr [Use Logo commands like lt 113 or rt 34]
cret
go "loopst]
make "q lc first :x
if not memberp :q [rt right lt left] [
pr [I can only turn right or left.]
pr []
cret
go "loopst]
make "q last :x
if not numberp :q [
pr [I need a number to tell me]
pr [how far to turn.]
cret
go "loopst]
if 1000 < abs :q [
pr [I'm getting dizzy!]
pr [Please, use numbers between]
pr [-1000 and 1000]
cret
go "loopst]
make "lturn (se :x)
run :x
end
to askyn :question
(local "ans)
label "flush
if keyp [make "ans rc go "flush]
(type :question) make "ans lc rc
(pr :ans) op :ans = "y
end
to play
(local "brisbane "sydney "melbourne "perth "darwin "ilbunga)
(local "places "start "src "dest "turn "x "ans "ldist "lturn)
setsplit 4 setbg 1 loadpic "aussie ct ss ht setpc 3
explain_game get_start
catch "cities [repeat 6 [get_dest player_moves]] ct
pr [Thus ends your vacation in Australia.]
(pr [Native guides helped you\ ] :turn [times\(s\).])
pr [We hope you will come back sometime.] cret
label "flush
if keyp [make "ans lc rc go "flush]
type [Play again (Y\/N) ?\ ] make "ans lc rc
(pr :ans) if :ans = "y [play]
end
to player_moves
(local "try)
ct pu setpos thing :src
make "try 1 make "ldist [] make "lturn []
label "loopst
pu setpos thing :src seth 0 st
get_heading
get_dist
if 8 <= dist thing :dest
[make "src :dest ct
(pr [You have arrived at] :dest [!])
pr [Not bad for a yank.] pr [] cret stop]
ct
pr [Silly tourist! You got lost and you]
(pr [had to fly back to] :src)
pr [] cret
make "try :try + 1 if :try < 6 [go "loopst]
ct pr [A friendly native guide helps you.]
seth towards thing :dest setpos thing :dest
pr [] pr [] cret make "src :dest
make "turn :turn + 1
end
to remove :object :objlist
if :object = first :objlist [op bf :objlist]
op fput (first :objlist) remove :object bf :objlist
end
to textfg :n
end
to sp :pal
local "bg
make "bg remainder (first sf) 16
if :pal > 2
[make "bg :bg + 16
make "pal :pal - 3]
if :pal = 0
[make "bg :bg + 32]
setbg :bg
end
to get_dest
if emptyp :places
[make "dest :start stop]
[make "dest first :places make "places bf :places]
end
to get_dist
(local "q "cmd)
label "loopst
ct
pr [Please move the turtle (ex: fd 30)]
if [] <> :ldist
[(pr [Your last try was:] :ldist)]
make "cmd rl if lc first :cmd = [quit] [throw "cities]
if 2 <> count :cmd [
pr [I need to know which way to]
pr [move, and how far to go.]
pr [Use Logo commands like fd 113 or bk 34]
cret
go "loopst]
make "q lc first :cmd
if not memberp :q [fd forward bk back] [
pr [I can only move forward or back.]
pr []
cret
go "loopst]
make "q last :cmd
if not numberp :q [
pr [I need a number to tell me]
pr [how far to move.]
cret
go "loopst]
if 1000 < abs :q [
pr [Your plane won't go that far.]
pr [Please use numbers between]
pr [-1000 and 1000]
cret
go "loopst]
setpc 2
make "ldist (se :cmd)
pd run :cmd pu
end
to get_start
make "brisbane [68 -1]
make "sydney [60 -17]
make "melbourne [28 -33]
make "perth [-84 -9]
make "ilbunga [-12 15]
make "darwin [-20 87]
make "places shuffle [brisbane sydney melbourne perth ilbunga darwin]
make "start first :places
make "places bf :places
make "src :start
make "turn 0
make "ldist []
make "lturn []
end
BFLY Enter a b c d e f (mixed) to see the butterfly
to bfly
splitscreen
label "loop0
make "units shuffle [p1 p2 p3 p4 p5 p6]
if :units = [p1 p2 p3 p4 p5 p6] [go "loop0]
make "letters shuffle [a b c d e f]
label "loopst
make "solved (:units = [p1 p2 p3 p4 p5 p6])
cs ct ht setpc 3 make "indx 1
pu setpos [-150 20] run bl bl bl :units
pu setpos [-150 -60] run bf bf bf :units
if :solved [stop]
label "loopb
type "\> make "ans rl make "nu []
if not ([a b c d e f] = sort :ans) [pr [Illegal] go "loopb]
repeat 6 [
if memberp (first :ans) :letters [
make "nu lput (item where :units) :nu
make "ans se (bf :ans) (first :ans)]]
make "units :nu
make "letters :ans
go "loopst
end
to border
if :solved [stop]
setpc 3 pd fd 80 lt 90 fd 100 lt 90 fd 80
pu bk 4 lt 90 fd 4 tt (item :indx :letters) bk 4 rt 90 fd 4
pd lt 90 fd 100 lt 90 make "indx :indx + 1
end
to dg :n
fd :n * 1.414
end
to p1
pu rt 90 fd 50 lt 135 pd
dg 20 rt 45 fd 30 rt 45 dg 10 rt 45 fd 50 rt 45
dg 10 rt 45 pu fd 10 rt 135 pd dg 10 lt 45
fd 50 lt 90 fd 30 lt 45 dg 20 lt 45
fd 40 lt 90 pu fd 10 lt 90 pd setpc 2
fd 50 pu bk 50 rt 90 fd 10 pd lt 90
repeat 3 [fd 60 pu bk 60 rt 90 fd 10 lt 90 pd]
pu rt 90 bk 50 setpc 3
border
end
to p2
(local "n) make "n 40
repeat 4 [pd rt 90 fd :n pu bk :n lt 90 fd 10 pd make "n :n - 10 setpc 2]
setpc 3 rt 135 dg 40 lt 135 fd 10 lt 45 dg 40 pu dg -40 pd
rt 90 dg 10 lt 75 fd 30 bk 30 rt 60 fd 30 bk 30 rt 15
rt 90 dg 10 rt 45 fd 10 bk 10 lt 135 dg 40 pu lt 45
bk 10 rt 45 pd dg -40 pu dg 40 lt 45 make "n 10 setpc 2
repeat 4 [
bk 10 lt 90 pd fd :n pu bk :n rt 90 make "n :n + 10 if :n = 40 [setpc 3]]
border
end
to p3
pu rt 90 fd 100 lt 90 pu lt 90 fd 50 rt 135 pd
dg 20 lt 45 fd 30 lt 45 dg 10 lt 45 fd 50 lt 45
dg 10 lt 45 pu fd 10 lt 135 pd dg 10 rt 45 fd 50 rt 90
fd 30 rt 45 dg 20 rt 45 fd 40 rt 90 pu fd 10 rt 90 pd setpc 2
fd 50 pu bk 50 lt 90 fd 10 pd rt 90
repeat 3 [fd 60 pu bk 60 lt 90 fd 10 rt 90 pd]
setpc 3 pu lt 90 bk 50 rt 90 fd 100 lt 90
border
end
to p4
pu fd 80 rt 90 fd 50 rt 135 pd
dg 10 lt 45 fd 30 lt 45 dg 20 lt 45 fd 30 lt 45 dg 10
pu lt 45 fd 10 lt 135 pd
dg 10 rt 45 fd 30 rt 45 dg 10 rt 45 fd 30 rt 45 dg 10 rt 45 setpc 1
repeat 4 [pd rt 90 fd 50 pu bk 50 lt 90 fd 10]
rt 90 pd fd 40 pu fd 40 rt 180 setpc 3
border
end
to p5
(local "n)
pu fd 30 rt 45 pd dg 40 pu lt 45 fd 10 rt 45 pd dg -40 pu make "n 30 setpc 1
repeat 3 [dg 10 lt 45 pd fd :n pu bk :n rt 45 make "n :n - 10] setpc 3
dg 10 rt 135 pd fd 20 lt 45 dg 10 lt 90 dg 10 lt 45 fd 20 rt 90 pu make "n 10
setpc 1 repeat 3 [fd 10 rt 90 pd fd :n pu bk :n lt 90 make "n :n + 10] setpc 3
fd 10 rt 90 fd 40 rt 135 pd dg 40 pu lt 135 fd 10 lt 45 pd dg 40
pu rt 45 fd 30 rt 180
border
end
to p6
pu rt 90 fd 100 pu lt 90 fd 80 lt 90 fd 50 lt 135 pd
dg 10 rt 45 fd 30 rt 45 dg 20 rt 45 fd 30 rt 45 dg 10
pu rt 45 fd 10 rt 135 pd dg 10 lt 45 fd 30 lt 45 dg 10
lt 45 fd 30 lt 45 dg 10 lt 45 setpc 1
repeat 4 [pd lt 90 fd 50 pu bk 50 rt 90 fd 10]
lt 90 pd fd 40 pu fd 40 lt 90 fd 100 lt 90 setpc 3
border
end
CARDS Blackjack
to blackjack
(local "dealer_pos "hidden_pos "player_pos "player_aces "dealer_aces)
(local "dealer_total "player_total "move "game_over "card "deck "hidden_card)
init_blackjack
shuffle_the_deck
deal_first_cards
if :dealer_total = 21 [show_hidden_card ct pr [The dealer wins - Blackjack!]
go "game_end]
if :player_total = 21 [ct pr [You win - Blackjack!] go "game_end]
while [not :game_over] [get_player_move if :move = "h [give_card_to "player
"TRUE if :player_total > 21 [make "game_over "TRUE ct pr [You have exceeded 21
- You lose.]]] if :move = "s [show_hidden_card make "game_over "TRUE while
[:dealer_total < 17] [give_card_to "dealer "TRUE if :dealer_total > 21 [ct pr
[The dealer has exceeded 21 - You win.]]]]]
if or (:player_total > 21) (:dealer_total > 21) [go "game_end]
if :player_total > :dealer_total [ct pr [You have the higher score, you win.]]
[ct pr [The dealer wins.]]
label "game_end
pr []
type [Would you like to try again (Y\/N) ?\ ]
if lc rc = "y [blackjack] [cs ct]
end
to draw_card :value :suit :up
(local "dcard "spot "sbs "sss)
if or (:value < 1) (:value > 13) [stop]
if or (:suit < 1) (:suit > 4) [stop]
ht setpc 3 pd repeat 2 [rt 90 fd 48 rt 90 fd 64] pu
if :up = "FALSE [stop]
make "dcard item :value [a 2 3 4 5 6 7 8 9 10 j q k]
make "spot char (:suit + 2)
make "sbs (word :spot "\ :spot)
make "sss (word :spot :spot :spot)
tat 4 -12 :dcard tat (if :value = 10 [28] [36]) -60 :dcard
if :value = 10 [tat 20 -20 :spot tat 20 -52 :spot]
if memberp :value [2 3] [tat 20 -28 :spot tat 20 -44 :spot]
if memberp :value [4 5 6 7] [tat 12 -28 :sbs tat 12 -44 :sbs]
if memberp :value [8 9 10] [tat 12 -28 :sss tat 12 -44 :sss]
if memberp :value [1 3 5 11 12 13] [tat 20 -36 :spot]
if memberp :value [6 8 10] [tat 12 -36 :sbs]
if memberp :value [7 9] [tat 12 -36 :sss]
end
to get_player_move
ct type [Do you Hit or Stand (H or S) ?]
make "move (lc rc) (pr :move)
end
to give_card_to :whom :up
make "card next_card
setpos thing (word :whom "_pos)
make (word :whom "_pos) (list xcor + 48 ycor)
draw_card (first :card) (last :card) :up
make (word :whom "_total) (thing (word :whom "_total)) + (value_of :card
:whom)
end
to init_blackjack
(local "x)
setres 0 setsplit 4 ss setpc 3 cs ct ht pu
make "player_pos [-150 90]
make "player_aces 0
make "player_total 0
make "dealer_pos [-150 0] make "hidden_pos [-150 0]
make "dealer_aces 0
make "dealer_total 0
make "game_over "FALSE
setpos [-150 95] pd tt "Your\ cards pu
setpos [-150 5] pd tt "Dealer's\ cards pu
pr [Let's play blackjack.]
pr [Please press any key to start.]
while [not keyp] [make "x random 100]
make "x rc pr []
end
to next_card
(local "x)
make "x first :deck
make "deck bf :deck
if emptyp :deck [shuffle_the_deck]
op :x
end
to show_hidden_card
setpos :hidden_pos
draw_card (first :hidden_card) (last :hidden_card) "TRUE
end
to shuffle_the_deck
make "deck shuffle [[1 1] [2 1] [3 1] [4 1] [5 1] [6 1] [7 1] [8 1] [9 1] [10
1] [11 1] [12 1] [13 1] [1 2] [2 2] [3 2] [4 2] [5 2] [6 2] [7 2] [8 2] [9 2]
[10 2] [11 2] [12 2] [13 2] [1 3] [2 3] [3 3] [4 3] [5 3] [6 3] [7 3] [8 3] [9
3] [10 3] [11 3] [12 3] [13 3] [1 4] [2 4] [3 4] [4 4] [5 4] [6 4] [7 4] [8 4]
[9 4] [10 4] [11 4] [12 4] [13 4]]
end
to value_of :card :whom
(local "x)
make "x first :card if :x > 10 [make "x 10]
if :x = 1 [make "x 11 make (word :whom "_aces) (thing (word :whom "_aces)) +
1]
if ((thing (word :whom "_total)) + :x) < 22 [op :x]
if (thing (word :whom "_aces)) < 1 [op :x]
make (word :whom "_aces) (thing (word :whom "_aces)) - 1
make "x :x - 10 op :x
end
to while :cond :body
label "loopst
if run :cond [run :body] [stop]
go "loopst
end
to tat :dx :dy :spot
(local "x) make "x pos
pu setpos (list xcor + :dx + 8 ycor + :dy) pd tt :spot pu setpos :x
end
to deal_first_cards
give_card_to "player "TRUE
give_card_to "dealer "FALSE make "hidden_card :card
give_card_to "player "TRUE
give_card_to "dealer "TRUE
end
ELIZA Is it a game?
to eliza
init.eliza
ct pr [Hello, I'm Eliza. What seems to be the problem]
loop [get.response if :response = [bye] [stop] next.question]
end
to get.response
(type [?]) make "response rl
if :response = :last.response
[pr [Please, don't repeat yourself.] get.response stop]
make "last.response :response
if memberp :response [[bye] [goodby] [goodbye] [shut up]]
[make "response [Bye] stop]
make "response keyword.match :response
end
to init.eliza
setres 0 ts ct
pr [Just a moment...]
make "keywords [afraid alike always am apologize are because cause causes
computer dream dreams fear fears feel friend friends friendship hate how i'm
love maybe no reasons sorry think what when yes you]
make "trans.1 [are am were was you i your my i've you've i'm you're me you
i'll you'll]
make "trans.2 [am are was were i you my your you've i've you're i'm you me
you'll i'll]
make "last.response []
make "afraid [[What causes such fears] [Are you more afraid than you should
be] [How long have you had such fears] [What else are you afraid of]]
make "alike [[How are these alike] [What other similarities are there] [Is the
connection a strong one] [What does that suggest to you]]
make "always [[Always is a long time] [How can you be sure] [What specific
incidents come to mind]]
make "am [[Did you come to me because you are *] [How long have you been *]
[Do you enjoy being *] [What are the benefits of being *]]
make "apologize [[There's no need to apologize] [Do you apologize often]
[Being a patient means never having to say you're sorry] [Apologies aren't
necessary]]
make "are [[What makes you think i am *] [Perhaps you would like to be *] [Do
you sometimes wish you were *] [Are you also *]]
make "because [[What other reasons might there be] [Is that the only reason]
[Does this explain anything else] [What do such reasons mean to you]]
make "cause shuffle :because
make "causes shuffle :because
make "computer [[Do computers worry you] [Are you frightened by computers]
[Don't you think computers can help people] [Why do you mention computers]]
make "dream [[What other dreams do you have] [Do you dream often] [What do you
dream about] [Are your dreams in color]]
make "dreams shuffle :dream
make "fear shuffle :afraid
make "fears shuffle :afraid
make "feel [[Does that trouble you] [Tell me more about such feelings] [Do you
often feel *] [Is it good to feel *]]
make "friend [[What qualities do you look for in friends] [Do you impose on
your friends] [Does the idea of friendship frighten you]]
make "friends shuffle :friend
make "friendship shuffle :friend
make "hate [[Why do you hate *] [Is hate the right word] [Why do you think
this is so]]
make "how [[What do you think] [Have you asked such questions before] [Does
that interest you] [What answer would you like to hear] [What comes to mind
when you ask that]]
make "I'm shuffle :am
make "love [[Why do you love *] [How deep is this love] [Is love appropriate
here] [What have you done about it]]
make "maybe [[You seem uncertain] [You aren't sure] [Don't you know] [Be more
emphatic]]
make "no [[Why not] [I disagree] [Are you sure] [That's quite negative] [Why
is that] [I agree]]
make "reasons shuffle :cause
make "think [[Do you really think so] [But you aren't sure *] [Do you doubt
*]]
make "what shuffle :how
make "when shuffle :how
make "yes [[I agree] [You seem quite certain] [Are you sure] [I disagree] [I
understand] [Why is that]]
make "you [[Oh, I *] [Let's discuss you, not me] [I'd rather talk about you]]
make "nokey [[Does that bother you] [What does that suggest to you] [I'm not
sure I understand] [Can you elaborate on that] [Tell me more]]
end
to keyword.match :set
if emptyp :set
[op "nokey]
repeat count :set
[if memberp (first :set) :keywords [op (first :set)] make "set bf :set]
op "nokey
end
to loop :body
label "loop
run :body
go "loop
end
to next.question
make "question first thing :response
make :response lput :question bf thing :response
if (last :question) <> "\*
[(pr :question) stop]
sink memberp :response :last.response
if or (where = 0) (where = count :last.response)
[pr bl :question stop]
type bl :question
trans piece (where + 1) (count :last.response) :last.response
end
to sink :n
end
to trans :set
type "\
repeat count :set
[if memberp (first :set) :trans.1
[type item where :trans.2]
[type (first :set)] type "\ make "set bf :set]
pr []
end
MAZE Maze game
to b_move :sz
if and (:h = 2) (:y > 1) [
if (item item :x :y - 1 :maze) = 1 [
if or (:y = 8) (:y = 2) [bk :sz / 2] [bk :sz]
make "y :y - 1]]
if and (:h = 0) (:y < 8) [
if (item :x item :y + 1 :maze) = 1 [
if or (:y = 7) (:y = 1) [bk :sz / 2] [bk :sz]
make "y :y + 1]]
if and (:h = 3) (:x < 12) [
if memberp 1 piece (:x + 1) 12 (item :y :maze) [
bk :sz make "x :x + 1]]
if and (:h = 1) (:x > 1) [
if memberp 1 piece 1 (:x - 1) (item :y :maze) [
bk :sz make "x :x - 1]]
end
to f_move :sz
if and (:h = 0) (:y > 1) [
if (item :x item :y - 1 :maze) = 1 [
if or (:y = 8) (:y = 2) [fd :sz / 2] [fd :sz]
make "y :y - 1]]
if and (:h = 2) (:y < 8) [
if (item :x item :y + 1 :maze) = 1 [
if or (:y = 7) (:y = 1) [fd :sz / 2] [fd :sz]
make "y :y + 1]]
if and (:h = 1) (:x < 12) [
if memberp 1 piece (:x + 1) 12 (item :y :maze) [
fd :sz make "x :x + 1]]
if and (:h = 3) (:x > 1) [
if memberp 1 piece 1 (:x - 1) (item :y :maze) [
fd :sz make "x :x - 1]]
end
to find_border :start :inc
label "find_b
if (item :start item :y :maze) = 0 [make "start :start + :inc go "find_b]
op :start
end
to get_exit :lrow
label "find_exit
make "x 2 + random 10 if (item :x :lrow) = 0 [go "find_exit]
op (se piece 1 :x - 1 [0 0 0 0 0 0 0 0 0 0 0] 1 piece :x 11 [0 0 0 0 0 0 0 0 0
0 0])
end
to inkey
(local "q)
ct type [Move (F, B, R, or L) ?\ ]
make "q rc
if :q = "f [f_move 30]
if :q = "b [b_move 30]
if :q = "r [r_move]
if :q = "l [l_move]
if :q = "s [stop]
inkey
end
to l_move
if :h = 0 [make "h 3] [make "h :h - 1]
lt 90
end
to maze
(local "i "rt_border "lt_border "h "x "y "maze)
cs setsplit 1 splitscreen pu setpc 3 setpos [-160 92] ht make "maze []
repeat 6 [make "maze fput (se 0 shuffle [0 0 0 0 1 1 1 1 1 1] 0) :maze]
make "maze fput get_exit first :maze lput get_exit last :maze :maze
make "y 2
repeat 6 [
make "lt_border find_border 2 1 make "rt_border find_border 11 -1
make "x :lt_border pu setx (-220 + 30 * :x) pd
repeat :rt_border - :lt_border + 1 [
make "i item :x item :y :maze
if (:i + item :x item :y - 1 :maze) = 2 [fd 15 pu rt 90 fd 15 pd]
rt 90 fd 15 seth 90
if :x = :rt_border [pd] [pu] seth 180 fd 15 pd
if (:i + item :x item :y + 1 :maze) = 2 [fd 15 pu rt 90 fd 15 pd]
rt 90 fd 15 seth 270
if :x > :lt_border [fd 15 pu rt 90 fd 15 pd]
rt 90 fd 15 seth 0
pu setx xcor + 30 pd make "x :x + 1]
pu sety ycor - 30 pd make "y :y + 1]
sink (memberp 1 last :maze) make "h 0 make "y 8 make "x where
pu setpos (se (-220 + 30 * :x) -80)
pd bk 20 setx xcor + 15 fd 20 pu setx xcor - 7.5 st
setpc 2 pd fill pu inkey
end
to r_move
if :h = 3 [make "h 0] [make "h :h + 1]
rt 90
end
to sink :n
end
REVERSE Game of Reverse
to ask :question
; Returns a user response to a question
(type :question)
op first rl
end
to askyn :question
; Returns TRUE if user answers question yes
local "ans
(type :question)
make "ans lc rc
(pr :ans)
op :ans = "y
end
to check_for_win
if not (:board = [0 1 2 3 4 5 6 7 8 9])
[stop]
make "game_over "TRUE
pr []
show :board
pr []
(pr [You've done it in only\ ] :move - 1 [\ moves!])
pr []
end
to reverse :set
; Returns a reversed copy of the input list
if emptyp :set
[op []]
op (se (list last :set) reverse bl :set)
end
to until :cond# :body#
; Perform the body until the condition is TRUE
label "loopst
run :body#
if not run :cond#
[go "loopst]
end
to sink :x
end
to explain_rules
ct
pr [This is the game of REVERSE]
pr []
pr [I will give you a scrambled list of 10 numbers, and you have]
pr [to put them in order, from the smallest to the largest.]
pr []
pr [The tricky part is that the only thing you can do is to reverse]
pr [some or all of the numbers. For example, if you have the list]
pr []
pr [\ \ \ \ \ \ \ \ [1 3 2 6 4 9 8 5 0 7]]
pr []
pr [and your reverse the first 5 numbers, the new list will be:]
pr []
pr [\ \ \ \ \ \ \ \ [4 6 2 3 1 9 8 5 0 7]]
pr []
pr [If you now reverse the first 3 numbers, the list becomes:]
pr []
pr [\ \ \ \ \ \ \ \ [2 6 4 3 1 9 8 5 0 7]]
pr []
pr []
type [Now, press the Enter key to begin.\ ]
sink rq
end
to init_game
ct
pr [The game of REVERSE]
pr []
make "board shuffle [0 1 2 3 4 5 6 7 8 9]
make "game_over "FALSE
make "move 1
end
to move
loop
[pr []
(pr [List is:] (list :board) [\ Move:] :move)
pr []
make "n ask [How many items to reverse?\ ]
if not numberp :n
[make "n 11]
if :n > 10
[pr [Sorry, I can't do that.]]
[stop]]
make "move :move + 1
if :n < 2
[stop]
make "board if :n = 10
[reverse :board]
[(se reverse piece 1 :n :board piece (:n + 1) 10 :board]
end
to play
; ... the game of REVERSE
(local "board "game_over "move "n "m)
explain_rules
loop
[init_game
until [:game_over] [move check_for_win]
if not askyn
[Play again (Y\/N) ?\ ]
[stop]]
end
to loop :body
label "loopst
run :body
go "loopst
end
WEST Railway game
to askyn :question
; Returns TRUE if user answers question yes
(local "ans)
(type :question)
make "ans lc rc
(pr :ans)
op :ans = "y
end
to at :n
if :n = 0 [op [-125 90]]
if :n = 122 [op [-125 -60]]
if :n < 27 [op list (:n * 10) - 117 90]
if :n < 32 [op list 148 355 - (:n * 10)]
if :n < 59 [op list 463 - (:n * 10) 40]
if :n < 64 [op list -122 625 - (:n * 10)]
if :n < 91 [op list (:n * 10) - 757 -10]
if :n < 96 [op list 148 895 - (:n * 10)]
op list 1103 - (:n * 10) -60
end
to bounce :who
(local "wn)
make "wn (word :who ".num)
setpos thing (word :who ".pos) if :who = "player1 [cross] [square]
if (thing :wn) < 30 [make :wn 0] [
if (thing :wn) < 62 [make :wn 29] [
if (thing :wn) < 94 [make :wn 61] [
make :wn 93]]]
make (word :who ".pos) at thing :wn
setpos thing (word :who ".pos) if :who = "player1 [cross] [square]
end
to cir
setpc 4 fd 8
repeat 3 [rt 90 fd 16]
rt 90 fd 8 pu rt 90 fd 16 lt 90
setpc 2 pd
end
to cross
setpc 3
seth 270 pu fd 2 rt 90 fd 2
seth 135 px fd 6 pu bk 3 lt 90 fd 3 px bk 2.5 pu bk 1 px bk 2.5 pu
end
to draw.board
make "tc 1
setsplit 4 splitscreen ht
cs pu setpos [-133 90] pd
cir rt 90
tick 26 hcir 1
tick 26 hcir -1
tick 26 hcir 1
tick 25
fd 10 pu fd 16 rt 90 sety ycor + 1 pd cir
pu setpos [43 90] seth 180 pd fd 25 rt 90 fd 70 lt 90 fd 25
pu setx xcor + 70 pd fd 25 rt 90 fd 70 lt 90 fd 25
pu setx xcor + 70 pd fd 25 rt 90 fd 70 lt 90 fd 25
end
to hcir :dir
make "n 1
fd 5 rt 90 * :dir fd 5 rt 90 fd 2 bk 4 fd 2 lt 90 setpc 2 make "tc :tc + 1
tick 2 pu fd 8 rt 90 pd cir pu lt 90 fd 8 pd tick 2
fd 5 rt 90 * :dir fd 5 rt 90 fd 2 bk 4 fd 2 lt 90 setpc 2 make "tc :tc + 1
end
to init.game :lp
setsplit 4 splitscreen
type [Player 1 ?\ ] make "player1 rq
type [Player 2 ?\ ] make "player2 rq
make "tc 1
if :lp = 0 [loadpic "west] [draw.board]
make "game.not.over "TRUE
seth 0 pu
setpos [-125 93] make "player1.pos [-125 93] cross
setpos [-125 87] make "player2.pos [-125 87] square
make "player1.num 0
make "player2.num 0
end
to move :who
local "x
make "x shuffle [1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16]
make "a item 1 :x make "b item 2 :x make "c item 3 :x
label "a
ct (pr word "A\= :a word "B\= :b word "C\= :c [P\=pass])
(type [Ok,] thing :who [do you want A, B, C, or P?\ ])
make "ans lc rc pr uc :ans
if not memberp :ans [a b c p] [go "a]
if :ans = "p [stop] [make "distance thing :ans]
if (thing (word :who ".num)) + :distance > 122 [go "a]
setpos thing (word :who ".pos) if :who = "player1 [cross] [square]
make (word :who ".num) :distance + thing (word :who ".num)
if memberp thing (word :who ".num) [16 42 80] [
make (word :who ".num) item where [49 73 113]]
make (word :who ".pos) at thing (word :who ".num)
if :player1.num = :player2.num [
if :who = "player1 [bounce "player2] [bounce "player1]]
setpos thing (word :who ".pos) if :who = "player1 [cross] [square]
if not (thing (word :who ".num)) = 122 [stop]
ct pr [You win!]
make "game.not.over "FALSE
end
to play :lp
init.game :lp
while [:game.not.over] [
move "player1
if :game.not.over [move "player2]]
if askyn [Play again (Y\/N) ?\ ] [play :lp]
end
to sort.procs
; Sorts procedures in workspace alphabetically
(local "x)
make "x sort proclist
if count :x = 1 [stop]
repeat (count :x) - 1 [
(follow (first :x) (first butfirst :x))
make "x butfirst :x]
end
to square
setpc 3 seth 270 pu fd 3 rt 90 fd 3
seth 90 px fd 6 rt 90 fd 6 rt 90 fd 6 rt 90 fd 6 pu
end
to tick :n
repeat :n [
fd 10 if :tc = 5 [make "tc 1 setpc 1]
rt 90 fd 2 bk 4 fd 2 lt 90 setpc 2 make "tc :tc + 1]
end
to verall
; Erases all procedures specified by user
(local "x "y)
make "x sort proclist
make "y []
pr []
repeat count :x [
type (se [Erase] first :x [\ (y / n) ?\ ])
if "y = lc rc [pr [y] make "y lput (first :x) :y] [pr [n]]
make "x bf :x]
pr [] pr [These procedures will be erased:] pr []
pr :y pr []
type [Is this what you want (Y\/N) ?\ ]
if "y = lc rc [pr [Y] erase :y] [pr [N]]
end
to while :cond :body
label "loopst
if run :cond [run :body] [stop]
go "loopst
end
Business Graphics
-----------------
BARCHART Programmed bar chart (not interactive)
to move_to :x :y :h :c
pu setpos (list :x - 158 :y - 89) setpc :c pd
fd :h rt 90 fd 20 rt 90 fd :h rt 90 fd 20 rt 90
pu sety ycor + 1 setx xcor + 1 pd fill pu sety ycor - 1 setx xcor + 20
end
to bar :h :c
setpc :c pd
repeat 2 [fd :h rt 90 fd 20 rt 90]
pu sety ycor + 1 setx xcor + 1 pd fill pu sety ycor - 1 setx xcor + 20
end
to plot_axis
ht pu
setpos [-158 -90] pd
repeat 17 [fd 10 setx -156 setx -158]
bk 170 rt 90
repeat 30 [fd 10 sety -88 sety -90]
bk 300 lt 90
end
to sample_boxes
move_to 10 0 60 1
move_to 30 0 50 2
move_to 50 0 75 3
move_to 70 0 40 1
move_to 90 0 50 2
move_to 110 0 90 3
move_to 130 0 80 1
move_to 150 0 60 2
move_to 170 0 110 3
move_to 190 0 90 1
move_to 210 0 100 2
move_to 230 0 120 3
end
to barchart
setres 1 fs
setbg 9 setpc 3 cs
plot_axis
sample_boxes
end
BCHART2 Interactive bar chart
to bar :n
if :n = 0 [if :typ = "n [setx xcor + :w] stop]
pd repeat 2 [fd :n rt 90 fd :w rt 90] pu rt 45 fd 3 pd fill pu bk 3 lt 45
if :typ = "y [fd :n + 1] [setx xcor + :w]
end
to axes
setpc 2 pu
setpos [-120 100] pd
setpos [-120 -50]
setpos [159 -50]
end
to months
local "x
make "x [j f m a m j j a s o n d]
pu setpos [-112 -60]
repeat 12 [pd tt first :x pu setx xcor + 22 make "x bf :x]
end
to chart
setres 0
getoptions
cs ht setbg 0
axes
months
seth 0
scale
setpos [-120 -50]
repeat 12 [pu setx xcor + 4 pd dobar if :typ = "y [setx xcor + 18]]
end
to dobar
setpc 1
repeat :v [
type [What is the next month's value?\ ]
make "ht readquote
bar :ht
setpc if pc = 3 [1] [pc + 1]]
pu sety -50
end
to scale
local "x
make "x [0 50 100 150]
pu setpos [-145 -50]
repeat 4 [pd tt first :x pu sety ycor + 50 make "x bf :x]
end
to getoptions
type [How many variables on the graph ?\ ]
make "v getnum
make "w 18
if :v = 1 [stop]
type [Stacked (or Clustered) (Y or N) ?\ ]
make "typ getyorn
if :typ = "n [make "w 18 / :v]
ct
end
to getnum
local "v
make "v readquote
if numberp :v [op :v]
getnum
end
to getyorn
local "yn
make "yn rq
if memberp :yn [y n] [op :yn]
getyorn
end
to pc
op item 5 tf
end
CHARTS Line, Pie, and Bar charts
to ask :question
; Returns a user response to a question
(type :question)
op first readlist
end
to askyn :question
; Returns TRUE if user answers question yes
(local "ans)
(type :question)
make "ans lc rc
(pr :ans)
op :ans = "y
end
to assign :var
make :var lc rq
if (thing :var) = "quit [throw "quit]
end
to bar.chart
init.chart [Bar chart maker 2 \/14\/84] 320 151
pu setpos [-160 -50] pd
catch "quit []
loop [
make "max.width round (160 - xcor)
label "a
ct pr [Type 'quit' at any time to stop.] pr []
(type [Heigth of bar (1 to 150) ?\ ])
assign "ht
if not numberp :ht [go "a] make "ht :ht + 0
if or (:ht < 1) (:ht > 150) [go "a]
label "b ct
(type [Width of bar (\ 1 to] :max.width [) ?\ ])
assign "wt
if not numberp :wt [go "b] make "wt :wt + 0
if or (:wt < 1) (:wt > :max.width) [go "b]
until [memberp :cl [0 1 2 3]] [
ct (type [What color is the bar (0 to 3) ?\ ])
assign "cl]
until [memberp :want.title [y n]] [
ct (type [Do you want to title the bar (Y\/N) ?\ ])
assign "want.title]
make "want.title first :want.title
if lc :want.title = "y [
(type [Title?\ ]) make "title rq
pu sety -55 pd setpc 15 tt :title pu sety -50 pd]
setpc :cl pd if :cl = 0 [setpc 3]
repeat 2 [fd :ht rt 90 fd :wt rt 90]
pu fd :ht / 2 rt 90 fd :wt / 2 pd
if :cl > 0 [fill]
pu fd :wt / 2 lt 90 bk :ht / 2
if xcor = 160 [stop]]
check.for.save
end
to border :wb :hb
pu setpos [-160 99] pd setpc 15 rt 90
repeat 2 [fd :wb rt 90 fd :hb rt 90]
end
to check.for.save
end
to draw.slices
catch "quit [loop [slice if heading = 0 [stop]]]
end
to init.chart :chart.info :wb :hb
splitscreen cs ct ht
make "pr.scrn askyn [Print chart when finished (Y\/N) ?\ ]
if :pr.scrn [setscrunch 1.21] [setscrunch 1]
until [memberp :p [0 1 2 3 4 5]] [
ct type [Palette (0 to 5) ?\ ] make "p rc]
sp :p ct border :wb - 1 :hb - 1
pr :chart.info pr []
(type [Title of chart?\ ])
make "title rq
pu setpos list (0 - 4 * (count :title)) 90
pd setpc 15 tt (list :title) pu
home fd 20
end
to inkey
; If a key has been pressed, return it, else return nothing
if keyp [op rc] [op []]
end
to line.chart
init.chart [Line chart maker 2 \/15\/84] 320 160
ct pr [Enter the equation to plot.]
pr [Use only factors of x and constants.]
type [y = \ ] make "equation (se [make "y] rl)
lint :equation ct
type [Lowest x = \ ] make "min.x 0 + rq
type [Highest x = \ ] make "max.x 0 + rq
if :max.x < :min.x [make "t :min.x make "min.x :max.x make "max.x :t]
make "delta.x (:max.x - :min.x) / 320
type [Lowest y = \ ] make "min.y 0 + rq
type [Highest y = \ ] make "max.y 0 + rq
if :max.y < :min.y [make "t :min.y make "min.y :max.y make "max.y :t]
make "delta.y (:max.y - :min.y) / 160
; Plot axes here
ct (pr [Plotting y =] bf bf :equation)
make "x :min.x make "n 0 pu setpos [-160 0]
repeat 320 [
run :equation
make "x :x + :delta.x
if or (:y < :min.y) (:y > :max.y) [pu] [pd]
setpos map :n (:y - :min.y) / :delta.y
make "n :n + 1]
check.for.save
end
to lint :stmt
end
to loop :body#
label "loopst
run :body#
go "loopst
end
to map :x :y
op list (:x - 160) (:y - 59)
end
to menu :menulist#
; Give user a list of choices and perform action(s) based on choice.
; Format of :menulist# is [choice1 action1 choice2 action2 ...]
(local "l# "m# "n#)
if emptyp :menulist# [stop]
label "loopst
make "l# :menulist#
make "n# 0
pr []
repeat (count :menulist#) / 2 [
make "n# :n# + 1
(pr :n# first :l#)
make "l# bf bf :l#]
pr [] type [Enter choice:]
make "m# first readlist
if not numberp :m# [go loopst]
make "m# int :m#
if or (:m# < 1) (:m# > :n#) [go "loopst]
run (se item :m# * 2 :menulist#)
end
to pie.chart
init.chart [Pie chart maker 2 \/14\/84] 320 160
draw.slices
check.for.save
end
to slice
make "max.deg 360 - heading
label "a
ct pr [Type 'quit' at any time to stop.] pr []
(type [Degrees in this slice (\ 1 to] :max.deg [) ?\ ])
assign "hd
if not numberp :hd [go "a] make "hd :hd + 0
if or (:hd < 1) (:hd > :max.deg) [go "a]
until [memberp :cl [0 1 2 3]] [
ct (type [What color is the slice (0 to 3) ?\ ])
assign "cl]
until [memberp (first :out) [y n]] [
ct (type [Pull slice out from center (Y\/N) ?\ ])
assign "out]
until [memberp :want.title [y n]] [
ct (type [Do you want to title slice (Y\/N) ?\ ])
assign "want.title]
make "want.title first :want.title
if lc :want.title = "y [(type [Title?\ ]) make "title rq]
if (first :out) = "y [pu rt :hd / 2 fd 7 lt :hd / 2 pd]
if :cl = 0 [setpc 3] [setpc :cl]
make "radius 60 make "amt :radius * 0.0175 pd
fd :radius rt 90
repeat :hd [fd :amt rt 1] rt 90
fd :radius rt 180 - (:hd / 2)
if :cl > 0 [pu fd 5 pd fill pu bk 5]
if :want.title = "y [
make "p pos make "h heading pu fd :radius pd fd 10
if :h < 181 [seth 90] [seth 270] pd fd 5 pu fd 2
if :h > 180 [fd 8 * (count :title)] pd setpc 15 tt (list :title) pu
setpos :p seth :h]
if (first :out) = "y [bk 7] rt :hd / 2
end
to until :cond# :body#
label "loopst
run :body#
if not run :cond# [go "loopst]
end
to sp :pal
local "bg
make "bg remainder (first sf) 16
if :pal > 2 [make "bg :bg + 16 make "pal :pal - 3]
if :pal = 0 [make "bg :bg + 32]
setbg :bg
end
PCHART Pie chart
to assign :var
make :var lc rq
if (thing :var) = "quit [throw "quit]
end
to border :wb :hb
pu setpos [-160 99] pd setpc 3 rt 90
repeat 2 [fd :wb rt 90 fd :hb rt 90]
end
to draw.slices
catch "quit [loop [slice if heading = 0 [stop]]]
end
to init.chart :chart.info :wb :hb
setres 0 setsplit 4 ss cs ct ht setbg 0
border :wb - 1 :hb - 1
pr :chart.info pr []
(type [Title of chart?\ ])
make "title rq
pu setpos list (0 - 4 * (count :title)) 90 pd
tt (list :title) pu
home fd 20
end
to loop :body
label "loop
run :body
go "loop
end
to pie.chart
init.chart [Pie chart maker 2 \/14\/84] 320 160 draw.slices
end
to slice
make "max.deg 360 - heading
label "a
ct pr [Type 'quit' at any time to stop.] pr []
(type [Degrees in this slice (\ 1 to] :max.deg [) ?\ ])
assign "hd
if not numberp :hd [go "a] make "hd :hd + 0
if or (:hd < 1) (:hd > :max.deg) [go "a]
until [memberp :cl [0 1 2 3]] [ct (type [What color is the slice (0 to 3) ?\
]) assign "cl]
until [memberp (first :out) [y n]] [ct (type [Pull slice out from center
(Y\/N) ?\ ]) assign "out]
until [memberp :want.title [y n]] [ct (type [Do you want to title slice (Y\/N)
?\ ]) assign "want.title make "want.title first :want.title]
if :want.title = "y [(type [Title?\ ]) make "title rq]
if (first :out) = "y [pu rt :hd / 2 fd 7 lt :hd / 2 pd]
if :cl = 0 [setpc 3] [setpc :cl]
make "radius 60 make "amt :radius * 0.0175 pd
fd :radius rt 90
repeat :hd [fd :amt rt 1] rt 90
fd :radius rt 180 - (:hd / 2)
if :cl > 0 [pu fd 5 pd fill pu bk 5]
if :want.title = "y
[make "p pos make "h heading pu fd :radius pd fd 10
if :h < 181 [seth 90] [seth 270] pd fd 5 pu fd 2
if :h > 180 [fd 8 * (count :title)] pd tt (list :title) pu
setpos :p seth :h]
if (first :out) = "y [bk 7] rt :hd / 2
end
to until :cond# :body#
label "loopst run :body# if not run :cond# [go "loopst]
end
Graphics
--------
BRAIDS
to braid :horiz :vert :sz
(local "s2 "h2 "s2h2)
if (remainder (2 * (:horiz + :vert) + 4) 3) > 0 [pr [Braid will not connect
properly.] stop]
make "s2 (sqrt 2) * :sz
make "h2 :s2 * 0.5
make "s2h2 :s2 + :h2
pu fd (:sz * 4) rt 45 fd :h2 lt 45 pd
repeat 2 [strip :vert corner strip :horiz corner]
pu lt 45 fd :h2 rt 45 bk (:sz * 5) pd
end
to braid_demo
fs cs setres 0 setsplit 1
(local "s)
make "s 18 * sqrt 2
pu setpos [-150 -95] pd ht
braid 19 12 6
pu rt 45 fd :s lt 45 pd braid 16 9 6
pu rt 45 fd :s lt 45 pd braid 13 6 6
pu rt 45 fd :s lt 45 pd braid 10 3 6
pu rt 45 fd :s lt 45 pd braid 7 0 6
end
to corner
lt 45 fd :h2 rt 45 fd :sz rt 45 fd :s2 rt 45 fd :sz * 3 rt 45 fd :s2h2 rt 90
fd :h2 rt 90 fd :s2 lt 45 fd :sz * 3 lt 90 fd :sz rt 45 fd :h2 pu bk :h2 rt 45
fd 2 pd fill pu bk 2 lt 135 setpc if pc = 3 [1] [pc + 1] fd :s2 pd lt 90 fd
:s2 * 2 pu rt 90 fd :h2 pd rt 90 fd :s2 * 2 rt 90 fd :h2 pu bk :h2 rt 45 fd 2
pd fill pu bk 2 lt 90 setpc if pc = 3 [1] [pc + 1] fd :sz rt 90 fd :sz * 2 pd
rt 45 fd :h2 rt 45 pu fd :sz pd rt 45 fd :h2 pu rt 90 fd :h2 pd rt 45 fd :sz
rt 45 fd :h2 pu bk :h2 rt 45 fd 2 pd fill pu bk 2 lt 90 bk :sz * 2.5 rt 90 fd
:sz * 1.5 rt 90 pd setpc if pc = 1 [3] [pc - 1]
end
to strip :n
repeat :n [lt 45 fd :h2 rt 45 fd :sz rt 45 fd :s2h2 rt 90 fd :h2 rt 90 fd :s2
lt 45 fd :sz rt 45 fd :h2 bk :h2 lt 90 pu bk 2 pd fill pu fd 2 setpc if pc = 3
[1] [pc + 1] fd :s2 pd fd :h2 lt 90 fd :h2 lt 45 fd :sz lt 45 fd :s2h2 pu lt
90 fd :h2 lt 90 pd fd :s2 rt 45 fd :sz pu lt 90 fd 2 pd fill pu bk 2 lt 135 fd
:s2h2 rt 45 fd :sz pd]
end
to sp :pal
local "bg
make "bg remainder (first sf) 16
if :pal > 2
[make "bg :bg + 16
make "pal :pal - 3]
if :pal = 0
[make "bg :bg + 32]
setbg :bg
end
to pc
op item 5 tf
end
CP Figure mixing hexagon and octagon
to cp :sz
; Usage: fs cp 12
fs cs ht
repeat 6 [
quad1 1 :sz fl 60
repeat 4 [quad2 2 :sz rt 30]
lt 60 bk :sz rt 60]
fd :sz + :sz rt 30 fr 90
repeat 6 [
triangle 3 :sz lt 150
square 2 :sz rt 90 trap 1 :sz rt 60 fd :sz
triangle 3 :sz fl 120
square 2 :sz lt 150 fl 180
quad1 1 :sz rt 60 fr 90]
lt 90 bk :sz lt 60 fr 60 fl 90
repeat 6 [
hexagon 3 :sz rt 120 fl 90 bk :sz
quad2 1 :sz rt 30
hexagon 3 :sz lt 60 bk :sz rt 120
quad2 1 :sz rt 30 fl 90 bk :sz]
rt 90 bk :sz lt 60 bk :sz rt 60 fl 60 fr 90 fl 60 fr 60
repeat 6 [
square 2 :sz fr 90 fl 30 fl 30
square 2 :sz fr 90 fl 60 fr 60 fl 60]
lt 120 fl 60
repeat 6 [
repeat 4 [quad1 1 :sz rt 60] fl 60 fl 120
trap 2 :sz fr 60 fl 120 fr 120
trap 2 :sz lt 60 fd :sz + :sz rt 120
trap 2 :sz rt 60
trap 2 :sz lt 60 fd :sz
quad1 1 :sz bk :sz rt 180
quad2 1 :sz lt 60
triangle 3 :sz fd :sz
quad2 1 :sz rt 30
square 2 :sz fl 30
trap 2 :sz rt 60
triangle 3 :sz fd :sz
triangle 3 :sz rt 60
quad2 1 :sz rt 30
quad2 1 :sz rt 30 fl 30
triangle 3 :sz fl 150
triangle 3 :sz rt 60 fl 30
quad2 1 :sz lt 60
triangle 3 :sz rt 60 fl 30
triangle 3 :sz lt 90
square 2 :sz fr 30 fr 60 fr 90
quad2 1 :sz fl 30 fl 60 fd :sz]
end
to figure :sz
repeat 6 [
quad1 1 :sz fd :sz lt 60
repeat 4 [quad2 2 :sz rt 30]
lt 60 bk :sz rt 60]
fd :sz + :sz rt 30 fd :sz rt 90
repeat 6 [
triangle 3 :sz lt 150
square 2 :sz rt 90 trap 1 :sz rt 60 fd :sz
triangle 3 :sz fd :sz lt 120
square 2 :sz rt 120 rt 90 fd :sz lt 180
quad1 1 :sz rt 60 fd :sz rt 90]
lt 90 bk :sz lt 60 fd :sz rt 60 fd :sz lt 90
repeat 6 [
hexagon 3 :sz rt 120 fd :sz lt 90 bk :sz
quad2 1 :sz rt 30
hexagon 3 :sz lt 60 bk :sz rt 120
quad2 1 :sz rt 30 fd :sz lt 90 bk :sz]
rt 90 bk :sz lt 60 bk :sz rt 60
fd :sz lt 60 fd :sz rt 90 fd :sz lt 60 fd :sz rt 60
repeat 6 [
square 2 :sz fd :sz rt 90 fd :sz lt 30 fd :sz lt 30
square 2 :sz fd :sz rt 90 fd :sz lt 60 fd :sz rt 60 fd :sz lt 60]
lt 60 bk :sz rt 60 bk :sz lt 90 bk :sz rt 60 bk :sz lt 30 bk :sz + :sz
end
to hexagon :c :sz
setpc :c pd
repeat 6 [fd :sz rt 60]
rt 30 pu fd :sz pd fill pu bk :sz lt 30
setpc 0 pd
repeat 6 [fd :sz rt 60] pu
end
to octagon :c :sz
setpc :c pd
repeat 8 [fd :sz rt 45]
rt 45 pu fd :sz pd fill pu bk :sz lt 45
setpc 0 pd
repeat 8 [fd :sz rt 45] pu
end
to quad1 :c :sz
setpc :c pd
repeat 2 [fd :sz rt 60 fd :sz rt 120]
rt 30 pu fd :sz pd fill pu bk :sz lt 30
setpc 0 pd
repeat 2 [fd :sz rt 60 fd :sz rt 120] pu
end
to quad2 :c :sz
setpc :c pd
repeat 2 [fd :sz rt 30 fd :sz rt 150]
rt 15 pu fd :sz pd fill pu bk :sz lt 15
setpc 0 pd
repeat 2 [fd :sz rt 30 fd :sz rt 150] pu
end
to square :c :sz
setpc :c pd
repeat 4 [fd :sz rt 90]
rt 45 pu fd :sz pd fill pu bk :sz lt 45
setpc 0 pd
repeat 4 [fd :sz rt 90] pu
end
to trap :c :sz
setpc :c pd
fd :sz rt 60 fd :sz rt 60 fd :sz rt 120 fd :sz + :sz rt 120 rt 30 pu fd :sz pd
fill pu bk :sz lt 30
setpc 0 pd
fd :sz rt 60 fd :sz rt 60 fd :sz rt 120 fd :sz + :sz rt 120 pu
end
to fl :ang
fd :sz lt :ang
end
to fr :ang
fd :sz rt :ang
end
to triangle :c :sz
setpc :c pd
repeat 3 [fd :sz rt 120]
rt 30 pu fd :sz / 2 pd fill pu bk :sz / 2 lt 30
setpc 0 pd
repeat 3 [fd :sz rt 120] pu
end
DDD Pseudo 3D with lines
to ddd
setbg 16 fs cs ht
;
; Building 1
;
setpc 2
pu setpos [-140 60] pd setpos [-75 60] setpos [-75 -85] setpos [-140 -85]
setpos [-140 60]
setpc 1
pu setpos [-75 60] pd setpos [-40 27] setpos [-40 -71] setpos [-75 -85]
pu setpos [-65 -80] pd setpos [-65 -40] setpos [-50 -40] setpos [-50 -74]
pu setpos [-70 0] pd setpos [-70 25] setpos [-60 18] setpos [-60 -5]
setpos [-70 0]
;
; Building 2
;
setpc 2
pu setpos [-39 -10] pd setpos [-10 -10] setpos [-10 -57] setpos [-39 -57]
pu setpos [-30 -15] pd setpos [-25 -15] setpos [-25 -28] setpos [-30 -28]
setpos [-30 -15]
setpc 1
pu setpos [-10 -10] pd setpos [10 -20] setpos [10 -50] setpos [-10 -57]
pu setpos [-3 -55] pd setpos [-3 -40] setpos [2 -40] setpos [2 -53]
pu setpos [3 -27] pd setpos [8 -28] setpos [8 -34] setpos [3 -32]
setpos [3 -27]
;
; Building 3
;
setpc 2
pu setpos [3 -16] pd setpos [3 -7] setpos [15 -7] setpos [15 -48]
setpos [11 -48]
pu setpos [3 -11] pd setpos [-7 -11]
setpc 1
pu setpos [15 -7] pd setpos [25 -20] setpos [25 -45] setpos [15 -48]
pu setpos [18 -46] pd setpos [18 -40] setpos [20 -40] setpos [20 -45]
pu setpos [20 -23] pd setpos [22 -25] setpos [22 -30] setpos [20 -28]
setpos [20 -23]
;
; Building 4
;
setpc 2
pu setpos [155 -99] pd setpos [155 -25] setpos [75 -25] setpos [75 -99]
setpos [155 -99]
setpc 1
pu setpos [75 -25] pd setpos [60 -32] setpos [60 -72] setpos [75 -99]
pu setpos [65 -82] pd setpos [65 -55] setpos [70 -58] setpos [70 -90]
;
; Building 5
;
setpc 2
pu setpos [95 -25] pd setpos [95 52] setpos [142 52] setpos [142 -25]
setpc 1
pu setpos [95 52] pd setpos [70 13] setpos [70 -27]
pu setpos [78 1] pd setpos [83 8] setpos [83 -6] setpos [78 -10]
setpos [78 1]
;
; Building 6
;
setpc 2
pu setpos [69 3] pd setpos [55 3] setpos [55 -65] setpos [59 -65]
pu setpos [69 -10] pd setpos [65 -10] setpos [65 -15] setpos [69 -15]
setpc 1
pu setpos [55 3] pd setpos [47 -15] setpos [47 -50] setpos [55 -65]
pu setpos [53 -60] pd setpos [53 -43] setpos [50 -42] setpos [50 -55]
;
; Road
;
setpc 3
pu setpos [-35 -100] pd setpos [40 -40] setpos [50 -100]
pu setpos [15 -100] seth 22.5
pd fd 20 pu fd 10 pd fd 10 pu fd 5 pd fd 5 pu fd 4 pd fd 4 pu fd 2 pd fd 2
;
; Horizon
;
pu setpos [-160 -40] pd setpos [-141 -40]
pu setpos [26 -40] pd setpos [46 -40]
pu setpos [156 -40] pd setpos [160 -40]
end
DENNIS Draws the face of "Dennis the Menace"
to dennis
fs cs setbg 0 setpc 1 ht pd rt 45
repeat 138 [fd 1 rt 1] pu setpos [-12.4 -18] seth 23 pd
repeat 22 [bk 1 lt 1] pu setpos [-7 -73] seth 325 pd
repeat 80 [bk 1 lt 1] rt 180
repeat 60 [fd 1 lt 2] rt 110
repeat 53 [fd 1 rt 4] pu home pd seth 140
repeat 55 [fd 2 lt 1] seth 320
repeat 55 [fd 2 lt 1] seth 115 fd 100 pu home pd rt 55
repeat 110 [fd 1 rt 1] pu home pd
repeat 30 [fd 1 lt 3] lt 60 fd 35 pu setpos [-14 -20] seth 0 pd
repeat 40 [fd 1 lt 5] pu setpos [-5 -45] seth 315 pd
repeat 90 [fd 1 lt 3] pu setpos [-8 -25] seth 85 pd
repeat 18 [fd 1 rt 1] pu setpos [8.77 -31] seth 268 pd
repeat 20 [fd 1 rt 1] pu setpos [30 -39] pd
repeat 72 [fd 3 bk 3 lt 5] pu setpos [61 -44] pd
repeat 72 [fd 2 bk 2 lt 5] pu setpos [55 -53] seth 30 pd
repeat 40 [fd 1 lt 6] pu setpos [52 -53] seth 355 pd
fd 4 rt 45 bk 4 lt 75 fd 4 rt 60 bk 4 pu setpos [40 -65] seth 200 pd bk 4
repeat 16 [fd 1 rt 5] pu setpos [40 -65] seth 320 pd
repeat 24 [bk 1 lt 5] pu setpos [30 -1] seth 130 fd 5 pd fd 15
rt 90 fd 1 rt 90 fd 15 lt 90 fd 1 lt 90 fd 15 pu setpos [60 -30] seth 55 pd
fd 12 rt 90 fd 1 rt 90 fd 12 lt 90 fd 1 lt 90 fd 12 pu setpos [20 -50] pd
fd 1 pu sety -55 pd fd 1 pu setx 25 pd
fd 1 pu setpos [65 -60] pd fd 1 pu sety -55 pd fd 1 pu setx 68 pd fd 1
ht
pu setpos [-140 70] pd setpc 4 tt [Dr. Logo] pu setpos [-70 70] pd setpc 2 tt
[is so fun and easy,] pu
pu setpos [-120 50] pd tt [even my Dad can learn it!] pu
end
DESIGN Draws a 5-items image
to design
; Usage: fs design
cs ht pu window
repeat 5 [fd 51.72 pd wheel pos pu bk 51.72 rt 72]
pu home rt 36 fd 19.6 rt 198 pd
centerpiece 36.8 143.4
end
to wheel :initpos
rt 54
repeat 4 [pentpiece]
pd lt 36
repeat 5 [tripiece]
lt 36
repeat 5 [pd rt 72 fd 22.4 pu bk 22.4]
lt 54
end
to tripiece
local "oldh make "oldh heading
pd bk 2
tripolyr 25.2
pu setpos :initpos seth :oldh
pd bk 2
tripolyl 25.2
pu setpos :initpos seth :oldh
lt 72
end
to pentpiece
local "oldh make "oldh heading
pu fd 23.2 pd
repeat 5 [fd 14.4 rt 72]
pentr 14.4 77
pu setpos :initpos seth :oldh
fd 23.2 pd
repeat 5 [fd 14.4 lt 72]
pentl 14.4 77
pu setpos :initpos seth :oldh
lt 72
end
to pentl :side :ang
if :side < 2 [stop]
fd :side
lt :ang
pentl :side - 0.45 :ang
end
to pentr :side :ang
if :side < 2 [stop]
fd :side
rt :ang
pentr :side - 0.45 :ang
end
to tripolyl :side
if :side < 4 [stop]
fd :side
lt 111
fd :side / 1.78
lt 111
fd :side / 1.3
lt 146
tripolyl :side * 0.75
end
to tripolyr :side
if :side < 4 [stop]
fd :side
rt 111
fd :side / 1.78
rt 111
fd :side / 1.3
rt 146
tripolyr :side * 0.75
end
to centerpiece :s :a
fd :s lt :a
if :s < 7.5 [stop]
centerpiece :s - 1.2 :a
end
DISCOVER Draws a Chinese word ("discover")
to discover :n
(local "sz)
cs pu setpos [-50 -21] ht
ht setbg 16 setpc :n
make "sz 0.6
seth 59.04 fd 58.31 * :sz pd
seth 12.25 fd 61.37 * :sz
seth 40.88 fd 26.38 * :sz
seth 255.22 fd 44.15 * :sz
seth 304.03 fd 18.16 * :sz
seth 70.09 fd 61.69 * :sz
seth 0.0945 fd 19.9 * :sz
seth 224.9 fd 14.12 * :sz
seth 270.88 fd 10.16 * :sz
seth 319.38 fd 19.97 * :sz
seth 125.4 fd 5.03 * :sz
seth 74.62 fd 30.06 * :sz
seth 0.17 fd 29.69 * :sz
seth 116.46 fd 22.44 * :sz
seth 182.37 fd 50.21 * :sz
seth 36.22 fd 6.21 * :sz
seth 14.95 fd 62.09 * :sz
seth 352.63 fd 7.81 * :sz
seth 127.96 fd 17.86 * :sz
seth 180.52 fd 20.24 * :sz
seth 50.82 fd 12.66 * :sz
seth 135.07 fd 14.32 * :sz
seth 187.63 fd 15.15 * :sz
seth 259.97 fd 28.6 * :sz
seth 199.32 fd 15.39 * :sz
seth 66.72 fd 38.02 * :sz
seth 124.49 fd 18.43 * :sz
seth 180.5 fd 10.13 * :sz
seth 270 fd 10.09 * :sz
seth 298.53 fd 4.55 * :sz
seth 250.51 fd 32.86 * :sz
seth 118.32 fd 22.6 * :sz
seth 230.12 fd 39.17 * :sz
seth 170.97 fd 6.01 * :sz
seth 75.93 fd 16.39 * :sz
seth 112 fd 8.7 * :sz
seth 161.91 fd 15.93 * :sz
seth 214.18 fd 18.23 * :sz
seth 135.05 fd 14.09 * :sz
seth 138.2 fd 25.5 * :sz
seth 219.9 fd 7.9 * :sz
seth 286.32 fd 7.39 * :sz
seth 333.58 fd 11.21 * :sz
seth 303.26 fd 23.8 * :sz
seth 233.22 fd 24.9 * :sz
seth 270.35 fd 12.06 * :sz
seth 285.74 fd 18.7 * :sz
seth 179.63 fd 9.77 * :sz
seth 269.99 fd 10.1 * :sz
seth 315.49 fd 14.27 * :sz pu
seth 77.16 fd 22.69 * :sz pd
seth 16.07 fd 14.5 * :sz
seth 42.73 fd 35.39 * :sz
seth 144.56 fd 12.65 * :sz
seth 74.17 fd 21.72 * :sz
seth 206.45 fd 22.41 * :sz
seth 303.56 fd 10.99 * :sz
seth 270.27 fd 18.94 * :sz
seth 123.49 fd 21.58 * :sz
seth 251.22 fd 19.12 * :sz
seth 257.69 fd 18.45 * :sz pu
seth 348.7 fd 15.53 * :sz pd
seth 3.38 fd 20.07 * :sz
seth 18.67 fd 31.66 * :sz
seth 45.67 fd 28.45 * :sz
seth 91.31 fd 10.24 * :sz
seth 196.17 fd 32.33 * :sz
seth 219.47 fd 50.49 * :sz pu
seth 43.32 fd 62.2 * :sz pd
seth 10.59 fd 23.16 * :sz
seth 124.34 fd 16.03 * :sz
seth 230.46 fd 22.11 * :sz pu
seth 11.36 fd 65.41 * :sz pd
seth 2.31 fd 9.93 * :sz
seth 83.69 fd 9.11 * :sz
seth 218.97 fd 14.29 * :sz pu
seth 85.56 fd 14.85 * :sz pd fill pu
seth 201.78 fd 161.68 * :sz pd
seth 257.64 fd 43.05 * :sz
seth 186.61 fd 9.59 * :sz
seth 135.34 fd 11.24 * :sz
seth 58.43 fd 15.2 * :sz
seth 192.07 fd 23.62 * :sz
seth 281.3 fd 15.33 * :sz
seth 219.95 fd 15.55 * :sz
seth 180.64 fd 17.84 * :sz
seth 135.57 fd 14 * :sz
seth 79.14 fd 10.08 * :sz
seth 26.67 fd 8.93 * :sz
seth 191.03 fd 20.43 * :sz
seth 194.05 fd 41.23 * :sz
seth 135.09 fd 14.11 * :sz
seth 90.1 fd 9.99 * :sz
seth 9.46 fd 60.81 * :sz
seth 1.39 fd 19.93 * :sz
seth 349.43 fd 10.17 * :sz
seth 21.92 fd 32.35 * :sz
seth 41.59 fd 15.79 * :sz
seth 308.62 fd 12.64 * :sz pu
seth 206.54 fd 55.77 * :sz pd
seth 287.16 fd 10.96 * :sz
seth 239.26 fd 5.81 * :sz
seth 180.08 fd 10.98 * :sz
seth 156.12 fd 9.84 * :sz
seth 28.78 fd 22.81 * :sz pu
seth 152.54 fd 11.44 * :sz pd fill pu
seth 33.65 fd 72.02 * :sz pd
seth 211.16 fd 12.21 * :sz
seth 183.47 fd 50.08 * :sz
seth 147.38 fd 17.78 * :sz
seth 54.43 fd 8.48 * :sz
seth 325.03 fd 12.14 * :sz
seth 3.82 fd 30.07 * :sz
seth 40.2 fd 13.06 * :sz
seth 64.44 fd 27.75 * :sz
seth 179.91 fd 61.19 * :sz
seth 278.05 fd 7.04 * :sz
seth 153.44 fd 13.41 * :sz
seth 74.13 fd 14.46 * :sz
seth 0.88 fd 65.98 * :sz
seth 316.47 fd 27.57 * :sz
seth 234.31 fd 30.59 * :sz
seth 327.93 fd 9.6 * :sz pu
seth 179.62 fd 19.92 * :sz pd fill pu
seth 114.22 fd 19.5 * :sz pd
seth 251.04 fd 6.38 * :sz
seth 180 fd 31.99 * :sz
seth 146.34 fd 3.61 * :sz
seth 217.05 fd 66.42 * :sz
seth 143.39 fd 4.95 * :sz
seth 71.65 fd 6.29 * :sz
seth 40.43 fd 52.46 * :sz
seth 188.82 fd 30.62 * :sz
seth 165.52 fd 10.26 * :sz
seth 119.62 fd 26.35 * :sz
seth 90.65 fd 21.86 * :sz
seth 49.64 fd 19.69 * :sz
seth 355.02 fd 9.87 * :sz
seth 11.33 fd 10.2 * :sz
seth 233.61 fd 18.56 * :sz
seth 252.81 fd 23.16 * :sz
seth 294.67 fd 19.91 * :sz
seth 8.7 fd 20.45 * :sz
seth 342.58 fd 12.54 * :sz
seth 15.85 fd 18.75 * :sz
seth 332.06 fd 10.1 * :sz
seth 42.28 fd 14.88 * :sz
seth 315 fd 16.9 * :sz pu
seth 170.53 fd 12.17 * :sz pd fill
pu seth 7.67 fd 119.05 * :sz pd
seth 38.26 fd 8.68 * :sz
seth 0.39 fd 4.98 * :sz
seth 90 fd 10.03 * :sz
seth 140.7 fd 14.22 * :sz
seth 225.09 fd 12.9 * :sz
seth 321.32 fd 12.83 * :sz
seth 251.76 fd 6.26 * :sz pu
seth 81.54 fd 14.13 * :sz pd fill pu home
end
to discover2 :n
; Usage: fs discover 4
(local "sz "l)
cs pu setpos [-50 -21] ht
setbg 8 setpc :n
make "sz 0.6
pu seth 59.04 fd 58.31 * :sz pd
shape [12.25 61.37 40.88 26.38 255.22 44.15 304.03 18.16 70.09 61.69 0.0945
19.9 224.9 14.12 270.88 10.16 319.38 19.97 125.4 5.03 74.62 30.06 0.17 29.69
116.46 22.44 182.37 50.21 36.22 6.21 14.95 62.09 352.63 7.81 127.96 17.86
180.52 20.24 50.82 12.66 135.07 14.32 187.63 15.15 259.97 28.6 199.32 15.39
66.72 38.02 124.49 18.43 180.5 10.13 270 10.09 298.53 4.55 250.51 32.86 118.32
22.6 230.12 39.17 170.97 6.01 75.93 16.39 112 8.7 161.91 15.93 214.18 18.23
135.05 14.09 138.2 25.5 219.9 7.9 286.32 7.39 333.58 11.21 303.26 23.8 233.22
24.9 270.35 12.06 285.74 18.7 179.63 9.77 269.99 10.1 315.49 14.27]
pu seth 77.16 fd 22.69 * :sz pd
shape [16.07 14.5 42.73 35.39 144.56 12.65 74.17 21.72 206.45 22.41 303.56
10.99 270.27 18.94 123.49 21.58 251.22 19.12 257.69 18.45]
pu seth 348.7 fd 15.53 * :sz pd
shape [3.38 20.07 18.67 31.66 45.67 28.45 91.31 10.24 196.17 32.33 219.47
50.49]
pu seth 43.32 fd 62.2 * :sz pd
shape [10.59 23.16 124.34 16.03 230.46 22.11]
pu seth 11.36 fd 65.41 * :sz pd
shape [2.31 9.93 83.69 9.11 218.97 14.29]
pu seth 85.56 fd 14.85 * :sz pd fill pu seth 201.78 fd 161.68 * :sz pd
shape [257.64 43.05 186.61 9.59 135.34 11.24 58.43 15.2 192.07 23.62 281.3
15.33 219.95 15.55 180.64 17.84 135.57 14 79.14 10.08 26.67 8.93 191.03 20.43
194.05 41.23 135.09 14.11 90.1 9.99 9.46 60.81 1.39 19.93 349.43 10.17 21.92
32.35 41.59 15.79 308.62 12.64]
pu seth 206.54 fd 55.77 * :sz pd
shape [287.16 10.96 239.26 5.81 180.08 10.98 156.12 9.84 28.78 22.81]
pu seth 152.54 fd 11.44 * :sz pd fill pu seth 33.65 fd 72.02 * :sz pd
shape [211.16 12.21 183.47 50.08 147.38 17.78 54.43 8.48 325.03 12.14 3.82
30.07 40.2 13.06 64.44 27.75 179.91 61.19 278.05 7.04 153.44 13.41 74.13 14.46
0.88 65.98 316.47 27.57 234.31 30.59 327.93 9.6]
pu seth 179.62 fd 19.92 * :sz pd fill pu seth 114.22 fd 19.5 * :sz pd
shape [251.04 6.38 180 31.99 146.34 3.61 217.05 66.42 143.39 4.95 71.65 6.29
40.43 52.46 188.82 30.62 165.52 10.26 119.62 26.35 90.65 21.86 49.64 19.69
355.02 9.87 11.33 10.2 233.61 18.56 252.81 23.16 294.67 19.91 8.7 20.45 342.58
12.54 15.85 18.75 332.06 10.1 42.28 14.88 315 16.9]
pu seth 170.53 fd 12.17 * :sz pd fill pu seth 7.67 fd 119.05 * :sz pd
shape [38.26 8.68 0.39 4.98 90 10.03 140.7 14.22 225.09 12.9 321.32 12.83
251.76 6.26]
pu seth 81.54 fd 14.13 * :sz pd fill pu home
end
to dist :c
op sqrt ((xcor - first :c) * (xcor - first :c) + (ycor - last :c) * (ycor -
last :c))
end
to shape :l
(local "n)
make "n 1
repeat (count :l) / 2 [
seth item :n :l make "n :n + 1
fd (item :n :l) * :sz make "n :n + 1]
end
DRAGON Fractals programs
to c_curve :size :level
if :level = 0 [fd :size stop]
c_curve :size :level - 1
rt 90
c_curve :size :level - 1
lt 90
end
to dragon :size :level
(local "n "max "flag)
make "n 0
make "flag "TRUE
make "max :level - 1
xldrag :size :level
end
to xldrag :size :level ; Used by dragon
if :level = 0 [
fd :size] [
xldrag :size :level - 1 lt 90 xrdrag :size :level - 1]
end
to xrdrag :size :level ; Used by dragon
if :level = 0 [fd :size] [
xldrag :size :level - 1 rt 90
if :flag [
if :level = (:n + 1) [
if (item 5 tf) = 3 [setpc 1] [setpc (item 5 tf) + 1]
make "n :n + 1
if :n = :max [make "flag "FALSE]]] [
if (:level + 1) = :n [
if (item 5 tf) = 3 [setpc 1] [setpc (item 5 tf) + 1]
make "n :n - 1]]
xrdrag :size :level - 1]
end
to hilbert :size :level :dir
if :level = 0 [stop]
lt 90 * :dir
hilbert :size :level - 1 (0 - :dir)
fd :size
rt 90 * :dir
hilbert :size :level - 1 :dir
fd :size
hilbert :size :level - 1 :dir
rt 90 * :dir
fd :size
hilbert :size :level - 1 (0 - :dir)
lt 90 * :dir
end
to nested_triangle :size
if :size < 10 [stop]
repeat 3 [nested_triangle :size / 2 fd :size rt 120]
end
to sierpinski :size :level
(local "diag)
make "diag :size / sqrt 2
repeat 4 [xside :level rt 45 fd :diag rt 45]
end
to xside :level ; Used by Sierpinski
if :level = 0 [stop]
xside :level - 1
rt 45 fd :diag rt 45
xside :level - 1
lt 90 fd :size lt 90
xside :level - 1
rt 45 fd :diag rt 45
xside :level - 1
end
to snowflake :size :level
if :level = 0 [
repeat 3 [fd :size rt 120]] [
repeat 3 [xflake :size :level rt 120]]
end
to xflake :size :level ; Used by snowflake
(local "tsize)
make "tsize :size / 3
if not (:level > 1) [
fd :tsize lt 60 fd :tsize rt 120 fd :tsize lt 60 fd :tsize] [
xflake :tsize :level - 1 lt 60
xflake :tsize :level - 1 rt 120
xflake :tsize :level - 1 lt 60
xflake :tsize :level - 1]
end
DRI Draws the Digital Research's logo
to curve
lt 9 fd 1 lt 9 fd 1 lt 9 fd 1 lt 9 fd 1 lt 9 fd 1 lt 9 fd 1 lt 9 fd 1 lt 9 fd
1 lt 9 fd 1 lt 9 fd 1
end
to box :x :y
repeat 2 [curve fd :x curve fd :y]
setx xcor - 1 sety ycor - 1
repeat 2 [curve fd :x - 2 curve fd :y - 2]
setx xcor - 1 sety ycor - 1
repeat 2 [curve fd :x - 4 curve fd :y - 4]
end
to outer
pu setpos [80 80] pd
box 160 150
end
to rbox
penup
setpos [60 60]
pendown
box 40 110
end
to lbox
pu setpos [-20 60] pd
box 40 110
pu setpos [-30 50] pd fill
end
to dri
setres 0 fs cs ht
setbg 8 setpc 2
outer rbox lbox setpc 3
pu setpos [-64 -90]
pd tt "Digital\ Research
end
DRLOGO Another version
to braid :horiz :vert :sz
(local "s2 "h2 "s2h2)
if (remainder (2 * (:horiz + :vert) + 4) 3) > 0 [pr [Braid will not connect
properly.] stop]
make "s2 :sz * 1.414 ; sqrt 2
make "h2 :s2 * 0.5
make "s2h2 :s2 + :h2
pu fd (:sz * 4) rt 45 fd :h2 lt 45 pd
repeat 2 [strip :vert corner strip :horiz corner]
pu lt 45 fd :h2 rt 45 bk (:sz * 5) pd
end
to circle
repeat 36 [fd 2 rt 10]
end
to corner
lt 45 fd :h2 rt 45 fd :sz rt 45 fd :s2 rt 45 fd :sz * 3 rt 45 fd :s2h2 rt 90
fd :h2 rt 90 fd :s2 lt 45 fd :sz * 3 lt 90 fd :sz rt 45 fd :h2 pu bk :h2 rt 45
fd 2 pd fill pu bk 2 lt 135 setpc if pc = 3 [1] [pc + 1] fd :s2 pd lt 90 fd
:s2 * 2 pu rt 90 fd :h2 pd rt 90 fd :s2 * 2 rt 90 fd :h2 pu bk :h2 rt 45 fd 2
pd fill pu bk 2 lt 90 setpc if pc = 3 [1] [pc + 1] fd :sz rt 90 fd :sz * 2 pd
rt 45 fd :h2 rt 45 pu fd :sz pd rt 45 fd :h2 pu rt 90 fd :h2 pd rt 45 fd :sz
rt 45 fd :h2 pu bk :h2 rt 45 fd 2 pd fill pu bk 2 lt 90 bk :sz * 2.5 rt 90 fd
:sz * 1.5 rt 90 pd setpc if pc = 1 [3] [pc - 1]
end
to drlogo
(local "y)
fs setbg 16 setpc 1 cs ht
face
pu setpos [-150 -99] pd ht seth 0
braid 21 13 6
pu setpos [-110 72] setpc 2 pd
tt [Digital Research presents:] pu
bk 30 setx xcor + 25 pd seth 0 setpc 3
;
; dr logo
;
make "y ycor fd 22 rt 90 repeat 18 [fd 2 rt 10]
pu setx xcor + 17 pd seth 0 fd 10 bk 3 rt 22 fd 3 seth 90 fd 5
pu seth 0 sety :y setx xcor + 20 pd fd 22 bk 22 rt 90 fd 15 pu fd 5
seth 0 fd 11 pd circle pu repeat 9 [fd 2 rt 10] fd 30 rt 180 pd
repeat 27 [fd 2 lt 10] lt 90 fd 10 pu bk 15 rt 90 pd circle
end
to face
(local "x "h)
glasses fd 25
repeat 36 [fd 1 lt 10] bk 4 rt 90
repeat 18 [fd 1 lt 10] fd 12
repeat 20 [fd 1 lt 10] seth 0 fd 25 pu bk 37 lt 90 fd 5 pd make "x pos
repeat 20 [fd 1 lt 3] pu setpos :x seth 90 pd
repeat 20 [fd 1 rt 3] pu setpos :x seth 180 pd
repeat 30 [fd 1 rt 5] pu setpos :x seth 225 pd
repeat 20 [fd 1 rt 2] pu setpos :x seth 135 pd
repeat 20 [fd 1 lt 2] pu setpos :x seth 180 pd
repeat 30 [fd 1 lt 6] seth 355 pu fd 26 pd fd 32 pu bk 60 seth 270 fd 40 rt 95
fd 27 pd fd 39 pu bk 42 lt 85 pd fd 12
repeat 9 [fd 1 lt 10]
repeat 22 [fd 1 lt 5] seth 190
repeat 26 [fd 2 lt 3] seth 0 pu fd 45 rt 90 fd 19 seth 355 fd 14 rt 85 pd fd
12
repeat 9 [fd 1 rt 10]
repeat 22 [fd 1 rt 5] seth 170
repeat 28 [fd 2 rt 3] seth -39 make "x pos
repeat 30 [fd 1 rt 1] pu setpos :x seth -26 pd
repeat 28 [fd 1 rt 1] pu setpos :x seth -13 pd
repeat 26 [fd 1 rt 1] pu setpos :x seth 13 pd
repeat 26 [fd 1 lt 1] pu setpos :x seth 26 pd
repeat 26 [fd 1 lt 1] pu setpos :x seth 39 pd
repeat 26 [fd 1 lt 1] pu setpos :x seth 52 pd
repeat 30 [fd 1 lt 1] pu setpos :x seth 0
fd 93 rt 90 bk 10 rt 30 pd fd 14 lt 60 fd 18 seth 0 fd 6 lt 90 bk 25 fd 75 lt
90 rt 6 make "x pos make "h heading
repeat 15 [fd 2 lt 1] pu setpos :x seth :h pd lt 6 fd 30 bk 30 make "h heading
repeat 15 [fd 2 rt 1] pu setpos :x seth :h pd lt 6 make "h heading
repeat 15 [fd 2 lt 1] pu setpos :x seth :h pd lt 6 make "h heading
repeat 15 [fd 2 rt 1] pu setpos :x seth 0
pd fd 3 rt 90 fd 37 rt 90 fd 1 lt 90 bk 36 fd 75 rt 90 fd 2 pu fd 69 rt 90 fd
36 lt 40 pd
repeat 14 [fd 1 rt 7] seth 0 pu fd 36 pd
repeat 60 [fd 2 bk 2 lt 6] seth 90 pu fd 18 pd
repeat 60 [fd 2 bk 2 lt 6] pu fd 50 rt 90 fd 50 pd setpc 3
end
to glasses
circle repeat 18 [fd 1 lt 10] circle
end
to strip :n
repeat :n [lt 45 fd :h2 rt 45 fd :sz rt 45 fd :s2h2 rt 90 fd :h2 rt 90 fd :s2
lt 45 fd :sz rt 45 fd :h2 bk :h2 lt 90 pu bk 2 pd fill pu fd 2 setpc if pc = 3
[1] [pc + 1] fd :s2 pd fd :h2 lt 90 fd :h2 lt 45 fd :sz lt 45 fd :s2h2 pu lt
90 fd :h2 lt 90 pd fd :s2 rt 45 fd :sz pu lt 90 fd 2 pd fill pu bk 2 lt 135 fd
:s2h2 rt 45 fd :sz pd]
end
to pc
op item 5 tf
end
FIGURE Draws an 3D hexagon?
to chevron :sz
fd :sz rt 45 fd :sz rt 45 fd :sz rt 45 fd :sz rt 45 fd :sz rt 135
fd :sz rt 45 fd :sz bk :sz lt 90 fd :sz rt 90 fd :sz bk :sz lt 135
fd :sz rt 135 fd :sz
end
to figure :sz :n :m
; Usage: ht figure 10 5 5
repeat 4 [
repeat :n [chevron :sz]
pu rt 45 fd :sz pd
repeat :m [chevron :sz]
pu rt 45 fd :sz pd]
end
GAGFILL Showed a problem on the EGA screen
to gagfill
wrap fs
cs ht setpc 3
repeat 160 [fd 200 pu setx (first tf) + 2 pd]
rt 90 setpc 0 fd 320
window rt 45 fd 200 bk 400 fd 200
rt 90 fd 200 bk 400 fd 200
setpc 2 pd fill
end
gagfill
HEART Draws three hearts (0.2, 0.35, and 0.5)
to heart :a
(local "x "y "r "theta)
ht pd make "x xcor make "y ycor
make "theta 0
repeat 37 [
make "r :a * :theta
setpos se :x + (:r * sin :theta) :y + (:r * cos :theta)
make "theta :theta + 5]
pu setpos se :x :y pd
make "theta 0
repeat 37 [
make "r :a * :theta
setpos se :x - (:r * sin :theta) :y + (:r * cos :theta)
make "theta :theta + 5]
pu setpos se :x :y pd
end
KEPLER
"I looked at that figure and saw isometric projections of a tetrahedron, a
cube and (when viewed from a different perspective) a stellated octahedron. I
had read on my own about Kepler's early idea about packed platonic solids, and
the design recalled it to me." Joe Power
to kepler :sz
; Usage: fs cs kepler 90
(local "p "amt)
make "amt :sz * 0.0175
make "p 2 * sqrt (:sz * :sz * 0.75)
setbg 0 setpc 4 ht
pu lt 90 fd :sz rt 90 pd
repeat 360 [fd :amt rt 1]
pu rt 90 fd :sz lt 90
repeat 3
[setpc 2 pd fd :sz
setpc 1 rt 120 fd :sz
rt 60 fd :sz bk :sz
rt 60 fd :sz / 2 pu fd :sz / 2]
fd :sz setpc 2 pd rt 30
repeat 3
[rt 120 fd :p]
pu lt 30 bk :sz pd
end
LETTERS Draws (literally) up to 3 names
to '
pu fd 12 rt 90 fd 8 lt 45 pd fd 11.2 pu lt 45 bk 20
end
to a
rt 30 pd fd 22.36
rt 120 fd 22.36 bk 11.18
lt 60 bk 11.18 fd 11.18
rt 60 fd 11.18
lt 150
end
to b
rt 90 pu fd 4 lt 90 pd fd 20 rt 90
fd 4 repeat 15 [fd 0.84 rt 12] fd 4 rt 180
fd 4 repeat 15 [fd 1.26 rt 12] fd 5 rt 180
pu fd 16 lt 90
end
to c
pu rt 90 fd 16 rt 180 pd fd 4
repeat 30 [fd 1.05 rt 6] fd 4
pu fd 4 lt 90 bk 20
end
to d
pu rt 90 fd 4 lt 90 pd fd 20
rt 90 pd fd 4
repeat 30 [fd 1.05 rt 6] fd 4
pu bk 16 rt 90
end
to e
pu rt 90 fd 4 lt 90 pd fd 20
rt 90 pd fd 12 bk 12
lt 90 bk 8 rt 90 fd 8 bk 8
lt 90 bk 12 rt 90 fd 12
pu fd 4 lt 90
end
to f
pu rt 90 fd 4 lt 90 pd fd 20
rt 90 pd fd 12 bk 12
lt 90 bk 8 rt 90 fd 8 bk 8
lt 90 bk 12 rt 90
pu fd 16 lt 90
end
to g
pu fd 20 rt 90 fd 11 rt 180
pd repeat 45 [fd 1.05 lt 6] lt 90 fd 10
pu bk 10 rt 90 bk 10
end
to h
pu rt 90 fd 4 lt 90 pd fd 20
pu bk 10 rt 90 pd fd 12 lt 90
pu fd 10 pd bk 20 pu rt 90 fd 4 lt 90
end
to i
pu rt 90 fd 6 pd fd 8 pu bk 4
lt 90 pd fd 20 pu lt 90 fd 4 pd bk 8
pu bk 6 rt 90 bk 20
end
to j
pu fd 20 rt 90 fd 4 rt 90 fd 14 pd
repeat 30 [fd 0.605 lt 6] fd 14
pu bk 20 rt 90 fd 4 lt 90 fd 1
end
to k
pu rt 90 fd 4 lt 90 pd fd 20 pu bk 10
rt 45 pd fd 14 pu bk 14 rt 90 pd fd 14 pu bk 14
lt 135 bk 10 rt 90 fd 16 lt 90
end
to l
pu rt 90 fd 4 lt 90 pd fd 20 pu bk 20
rt 90 pd fd 12 pu fd 4 lt 90
end
to m
pu rt 90 fd 4 lt 90 pd fd 20 rt 135 fd 8.49 lt 90 fd 8.49
rt 135 fd 20 pu lt 90 fd 4 lt 90
end
to n
pu rt 90 fd 4 lt 90 pd fd 20 rt 150 fd 23 lt 150 fd 20
pu bk 20 rt 90 fd 4 lt 90
end
to o
pu fd 10 pd
repeat 60 [fd 1.05 rt 6]
pu bk 10 rt 90 fd 20 lt 90
end
to p
pu rt 90 fd 4 lt 90 pd fd 20 rt 90
fd 4 repeat 30 [fd 0.525 rt 6] fd 4
pu bk 16 rt 90 bk 10
end
to q
pu fd 10 pd
repeat 60 [fd 1.05 rt 6]
pu lt 90 bk 10 rt 45 bk 5 pd bk 9.142 rt 45
end
to r
pu rt 90 fd 4 lt 90 pd fd 20 rt 90
fd 4 repeat 30 [fd 0.525 rt 6] fd 4
rt 45 bk 14.142 pu lt 45 bk 6 rt 90
end
to s
pu rt 90 fd 4 pd fd 8
repeat 30 [fd 0.525 lt 6] fd 4
repeat 30 [fd 0.525 rt 6] fd 8
pu fd 4 lt 90 bk 20
end
to t
pu fd 20 rt 90 fd 4 pd fd 12 pu bk 6 lt 90
pd bk 20 pu rt 90 fd 10 lt 90
end
to u
pu fd 20 rt 90 fd 4 rt 90 pd
fd 14 repeat 45 [fd 0.42 lt 4] fd 14
pu bk 20 rt 90 fd 4 lt 90
end
to v
pu fd 20 rt 150 pd
fd 22.36 lt 120 fd 22.36 pu lt 30 bk 20
end
to w
pu fd 20 rt 166 pd
repeat 2 [fd 20.61 lt 152 fd 20.61 rt 152]
pu lt 166 bk 20
end
to x
pu fd 20 rt 135 pd fd 28.28
pu lt 135 fd 20 rt 45 pd bk 28.28
pu rt 45 fd 20 lt 90
end
to y
pu fd 20 rt 90 fd 4 rt 60 pd fd 10 rt 30 fd 11
pu bk 11 lt 150 pd fd 10 pu rt 60 fd 4 lt 90 bk 20
end
to z
pu fd 20 rt 90 fd 4 pd fd 16
rt 135 fd 28.28 lt 135 fd 16 pu fd 4 lt 90
end
to draw :characters
if emptyp :characters [stop]
run (se (lc first :characters))
draw bf :characters
end
to my.name.is :namelist
; Usage: fs cs ht my.name.is [Praenom Nomen Cognomen]
cs setbg 0 setpc 15 pu setpos [-50 45]
h e l l o
make "namelist (se :namelist)
pu setpos (se (0 - ((count first :namelist) * 10)) 5)
setpc 4 draw first :namelist
if (count :namelist = 1) [stop]
pu setpos (se (0 - ((count item 2 :namelist) * 10)) -25)
setpc 2 draw item 2 :namelist
if (count :namelist = 2) [stop]
pu setpos (se (0 - ((count item 3 :namelist) * 10)) -55)
setpc 1 draw item 3 :namelist
end
MTURTLE Demo of multiple turtles (4)
to ask :name
local "ntf
make :current_turtle tf
make "ntf thing :name
pu ht
setpos (piece 1 2 :ntf)
seth (item 3 :ntf)
setpen (piece 4 5 :ntf)
if last :ntf [st]
make "current_turtle :name
end
to hatch :name
make :name tf
end
to mt
local "studs
make "studs tf
make "current_turtle "studs
end
to mt.demo
(local "bob "carol "ted "alice "temp)
setres 0 ht fs mt
setpc 1 pu setpos [-99 99] pd hatch "bob
setpc 2 pu setpos [99 99] pd hatch "carol
setpc 4 pu setpos [99 -99] pd hatch "ted
setpc 15 pu setpos [-99 -99] pd hatch "alice
repeat 27
[ask "bob make "temp pos seth towards (piece 1 2 :carol) fd 10
ask "carol seth towards (piece 1 2 :ted) fd 10
ask "ted seth towards (piece 1 2 :alice) fd 10
ask "alice seth towards :temp fd 10]
end
POLAR Draws 4 polar graphs
to archimedes :a
setpc 1
make "theta 0
loop [
make "r :a * :theta
setpos se (:r * cos :theta) (:r * sin :theta)
make "theta :theta + 5 if :theta > 360 [stop]]
end
to cardiod :a
setpc 1 make "theta 0
loop [
make "r (:a * (1 - cos :theta))
setpos se (:r * cos :theta) (:r * sin :theta)
make "theta :theta + 5 if :theta > 360 [stop]]
end
to coord
ht make "theta 0
cs setpc 4
pu bk 100 pd fd 200 setpc 2
pu bk 100 lt 90 fd 160 lt 180
pd fd 320 pu rt 180 fd 160 rt 90 pd
end
to limacon :a :b
; Usage: cs fs limacon 60 80
setpc 2 make "theta 0
loop [
make "r (:b - :a * cos :theta)
if :theta = 0 [pu] [pd] setpos se (:r * cos :theta) (:r * sin :theta)
make "theta :theta + 5 if :theta > 360 [stop]]
end
to loop :body
label "l
run :body
go "l
end
to plotxy :r :theta
setpos se (:r * cos :theta) (:r * sin :theta)
end
to rose3 :a
setpc 1 make "theta 0 pu
loop [
make "r (:a * cos (3 * :theta))
setpos se (:r * cos :theta) (:r * sin :theta) pd
make "theta :theta + 5 if :theta > 180 [stop]]
end
to rose4 :a
make "theta 0 setpc 1 pu
loop [
make "r (:a * cos (2 * :theta))
setpos se (:r * cos :theta) (:r * sin :theta) pd
make "theta :theta + 5 if :theta > 360 [stop]]
end
to title :string
pu setpos [-150 80]
pd setpc 15 tt :string pu
home pd
end
to polar
ct
print [This is a demonstration using Dr. Logo (tm) as a tool in the study]
print [of the polar coordinates. The first diagram is a graph of the function]
print [] print [\ \ \ \ r = a cos theta] print []
print [In just a second, the screen will switch to graphics and the plot]
print [will begin.]
wait 32000 make "theta 0 fullscreen
coord title [r = a cos theta]
rose3 70 wait 32000
coord title [Four petaled rose]
rose4 70 wait 32000
coord title [Cardiod]
cardiod 50 wait 32000
coord title [Spiral of Archimedes]
archimedes 0.25
end
QBERT 5-level cascade of cubes
to qbert
(local "x "y "q)
make "q 18.385 setres 0
fs cs ht pu setpos [-70 -85]
row 5 row 4 row 3 row 2 row 1
end
to row :n
make "x xcor make "y ycor
repeat :n [
setpc 1 pd repeat 2 [fd :q rt 135 fd :q rt 45]
pu setx xcor + 5 pd fill pu setx xcor - 5 lt 45 bk :q
seth 0 setx xcor + 1 setpc 3 pd repeat 2 [fd :q rt 45 fd :q rt 135]
pu setx xcor + 5 sety ycor + 8 pd fill pu setx xcor - 5 sety ycor - 8
rt 45 fd :q seth 0 setx xcor + 1]
pu setx :x sety :y + :q seth 45
setpc 2
repeat :n [
pd repeat 4 [fd :q rt 90] pu setx xcor + 5 pd fill pu setx xcor + 23.1]
pu setx :x sety :y + :q seth 45 fd :q seth 0
end
ROSE Draws variable-leaves rose
to rose :a :n :h
; Usage: cs fs rose 90 20 5
(local "theta "r)
cs ht setpc 3 pd
make "theta 0
repeat 360 * :h [
make "r (:a * sin (:n * :theta))
setpos (list (:r * cos :theta) (:r * sin :theta))
make "theta :theta + 1]
end
SHAPES Draws 5 drawings
to shape1
(local "n "o "p "q)
fs cs ht make "p pos pu setx xcor + 98 pd
make "o 1.71 ; 98 * pi / 180
repeat 360 [fd :o lt 1]
pu setpos :p make "n 1
repeat 72 [
fd 98 make "q pos setpos :p seth 10 * :n
fd 98 pd setpos :q pu setpos :p seth 5 * :n - 5
make "n :n + 1]
end
to shape2
(local "tsz "sz "p "q)
fs cs rt 18 make "sz 60 make "tsz 20
repeat 5 [
fd 20 lt 108 fd 20 rt 72
fd 20 rt 72 fd 20 rt 72
fd 20 lt 108 fd 20 rt 72]
repeat 5 [fd 60 rt 72]
make "p []
repeat 6 [
fd 30 rt 90 fd 20 make "q pos
if :p = [] [make "p pos] [setpos :p setpos :q make "p :q]
bk 20 lt 90 fd 30 rt 72]
pu fd 20 lt 90 fd 15 pd lt 18
repeat 5 [fd 5 rt 72] pu rt 18 bk 15 rt 90
pu fd 20 lt 90 fd 15 pd rt 18
repeat 5 [fd 5 lt 72] pu lt 18 bk 15 rt 90
bk 40 lt 72 bk 60 lt 12
end
to shape3
fs cs pu setpos [-150 80] rt 180 pd
fd 160 lt 90 fd 60 lt 90 fd 20 lt 90 fd 40 rt 90 fd 140 lt 90 fd 20
pu bk 2 lt 90 fd 2 pd fill
pu setpos [-70 80] seth 90 pd
repeat 2 [fd 60 rt 90 fd 160 rt 90]
pu setpos [-50 60] pd
repeat 2 [fd 20 rt 90 fd 120 rt 90]
pu fd 2 lt 90 fd 2 pd fill
pu setpos [10 80] seth 180 pd
fd 160 lt 90 fd 60 lt 90 fd 60 lt 90 fd 30 lt 90 fd 20 lt 90 fd 10
rt 90 fd 20 rt 90 fd 20 rt 90 fd 120 rt 90 fd 40 lt 90 fd 20 lt 90 fd 60
pu bk 2 lt 90 fd 2 pd fill
pu setpos [90 80] seth 90 pd
repeat 2 [fd 60 rt 90 fd 160 rt 90]
pu setpos [110 60] pd
repeat 2 [fd 20 rt 90 fd 120 rt 90]
pu fd 2 lt 90 fd 2 pd fill
end
to shape4
setbg 16 fs cs ht
;
; Building 1
;
setpc 2
pu setpos [-140 60] pd setpos [-75 60] setpos [-75 -85] setpos [-140 -85]
setpos [-140 60]
setpc 1
pu setpos [-75 60] pd setpos [-40 27] setpos [-40 -71] setpos [-75 -85]
pu setpos [-65 -80] pd setpos [-65 -40] setpos [-50 -40] setpos [-50 -74]
pu setpos [-70 0] pd setpos [-70 25] setpos [-60 18] setpos [-60 -5]
setpos [-70 0]
;
; Building 2
;
setpc 2
pu setpos [-39 -10] pd setpos [-10 -10] setpos [-10 -57] setpos [-39 -57]
pu setpos [-30 -15] pd setpos [-25 -15] setpos [-25 -28] setpos [-30 -28]
setpos [-30 -15]
setpc 1
pu setpos [-10 -10] pd setpos [10 -20] setpos [10 -50] setpos [-10 -57]
pu setpos [-3 -55] pd setpos [-3 -40] setpos [2 -40] setpos [2 -53]
pu setpos [3 -27] pd setpos [8 -28] setpos [8 -34] setpos [3 -32]
setpos [3 -27]
;
; Building 3
;
setpc 2
pu setpos [3 -16] pd setpos [3 -7] setpos [15 -7] setpos [15 -48]
setpos [11 -48]
pu setpos [3 -11] pd setpos [-7 -11]
setpc 1
pu setpos [15 -7] pd setpos [25 -20] setpos [25 -45] setpos [15 -48]
pu setpos [18 -46] pd setpos [18 -40] setpos [20 -40] setpos [20 -45]
pu setpos [20 -23] pd setpos [22 -25] setpos [22 -30] setpos [20 -28]
setpos [20 -23]
;
; Building 4
;
setpc 2
pu setpos [155 -99] pd setpos [155 -25] setpos [75 -25] setpos [75 -99]
setpos [155 -99]
setpc 1
pu setpos [75 -25] pd setpos [60 -32] setpos [60 -72] setpos [75 -99]
pu setpos [65 -82] pd setpos [65 -55] setpos [70 -58] setpos [70 -90]
;
; Building 5
;
setpc 2
pu setpos [95 -25] pd setpos [95 52] setpos [142 52] setpos [142 -25]
setpc 1
pu setpos [95 52] pd setpos [70 13] setpos [70 -27]
pu setpos [78 1] pd setpos [83 8] setpos [83 -6] setpos [78 -10]
setpos [78 1]
;
; Building 6
;
setpc 2
pu setpos [69 3] pd setpos [55 3] setpos [55 -65] setpos [59 -65]
pu setpos [69 -10] pd setpos [65 -10] setpos [65 -15] setpos [69 -15]
setpc 1
pu setpos [55 3] pd setpos [47 -15] setpos [47 -50] setpos [55 -65]
pu setpos [53 -60] pd setpos [53 -43] setpos [50 -42] setpos [50 -55]
;
; Road
;
setpc 3
pu setpos [-35 -100] pd setpos [40 -40] setpos [50 -100]
pu setpos [15 -100] seth 22.5
pd fd 20 pu fd 10 pd fd 10 pu fd 5 pd fd 5 pu fd 4 pd fd 4 pu fd 2 pd fd 2
;
; Horizon
;
pu setpos [-160 -40] pd setpos [-141 -40]
pu setpos [26 -40] pd setpos [46 -40]
pu setpos [156 -40] pd setpos [160 -40]
end
to shape5
fs cs setbg 17 ht lt 90 pu fd 160 rt 90 bk 50 setpc 3 pd
repeat 6 [
repeat 2 [fd 60 rt 90 fd 50 rt 90]
fd 60 rt 30 repeat 3 [fd 50 rt 120]
rt 150 fd 60 lt 90 fd 20 lt 90 repeat 2 [fd 30 rt 90 fd 10 rt 90]
pu fd 70 pd repeat 4 [fd 10 rt 90]
setpc 1 pu bk 70 rt 90 fd 30 pd repeat 20 [lt 9 fd 15 bk 15] setpc 3 seth 0]
repeat 2 [fd 120 rt 90 fd 10 rt 90]
fd 60 lt 90 repeat 2 [fd 300 rt 90 fd 44 rt 90]
pu seth 0 fd 60 lt 45 pd setpc 3 repeat 36 [fd 3 lt 2] repeat 36 [fd 3 rt 2]
end
STAR Draws a 5-arms star
to cover
setpc 4
fs cs pu setpos [-60 -100] pd ht
star 2.3
end
to gap
pu fd (:d * :n) pd
end
to star :n
rt 18
setpc 4 star1 40 8 34 4 3 9
setpc 2 star1 30 10 24 4 3 9
setpc 1 star1 14 12 20 4 3 9
setpc 15 star1 4 14 10 4 3 9
end
to star1 :a :b :c :d :e :f
repeat 5 [fd (:a * :n) gap fd (:b * :n) gap fd (:c * :n) rt 144]
pu rt 90 fd (:e * :n) lt 90 fd (:f * :n) pd
end
STRING
to string :sz :offset :halves
; Usage: cs fs string 90 0 5
(local "n "o "p "q)
make "o 1.745e-002 * :sz
clean ht make "p pos
pu setx xcor + :sz pd
repeat 360 [fd :o lt 1]
pu setpos :p make "n 1
repeat 36 * :halves [
pu fd :sz make "q pos setpos :p
seth remainder (5 * :n * :offset) 360
fd :sz pd setpos :q pu setpos :p
seth remainder (5 * (:n - 1)) 360
make "n :n + 1]
end
STUFF Contains 10 programs
to rocket
(local "v)
setpc 2
make "v 0
repeat 10000
[repeat 10000
[right ((joyin 0) - 64) / 4
make "v :v + (64 - joyin 1) / 32
forward :v
if buttonp 0 [setpc pc + 1]
[] if buttonp 1 [cs make "v 0]
[]]]
end
to etch
(local "x "y)
cs
setbg 19
make "x 0
make "y 0
repeat 10000
[repeat 10000
[make "x :x + ((joyin 0) - 64) / 4
make "y :y + (64 - joyin 1) / 4
if buttonp 0 [setpc pc + 1]
[] if buttonp 1 [cs make "x 0 make "y 0]
[] setpos list :x :y]]
end
to demo
setbg 3
setpc 2
clrs cs
hideturtle
(print []) (print [])
(ipr [Dr. Logo demonstration])
(pr []) (pr [])
delay
(pr [Logo uses a graphics cursor known as a "turtle".])
(pr [])
(pr [The turtle is displayed as an arrowhead. The following command])
(pr [enables the turtle:])
(pr [])
(ipr [?showturtle])
delay
showturtle
delay
(pr [])
(pr [The turtle has an x,y position and a heading, expressed in degrees.])
(pr [The turtle shown above is at (0 ,0) , with a heading of 0 degrees.])
(pr [])
delay
(pr [The turtle may be rotated. For instance, the following command])
(pr [will rotate the turtle 45 degrees to the right:])
(ipr [?right 45])
delay
right 45
delay
(pr [])
(pr [This command causes the turtle to spin in place...])
(pr [])
(ipr [?repeat 720 [right 5]])
(pr [])
repeat 720 [rt 5]
delay
clrs cs
(pr [The turtle may be moved about the screen with the FORWARD command])
(pr [])
(pr [for example])
(ipr [?repeat 72 [forward 5 right 5]])
(pr [causes the turtle to draw a circle...])
delay
repeat 72 [fd 5 rt 5]
delay
(pr [])
(pr [This command may be placed in a logo "procedure" called circle,])
(pr [so that it may be repeatedly invoked.])
(pr [])
(pr [This procedure might look something like this:])
(pr [])
po "circle
(pr [])
(pr [This procedure can be iteratively invoked like this:])
(ipr [?repeat 36 [circle right 10]])
delay
repeat 36 [circle rt 10]
delay
clrs
runner [gsq 1]
end
to clrs
type (word char 27 "E char 27 "H)
end
to inverse
type word char 27 "P
end
to normal
type word char 27 "Q
end
to delay
wait 5
end
to ipr :l
(pr [])
inverse (print :l) normal
(pr [])
end
to circle
repeat 72 [forward 5 right 5]
end
to shape
fd 40 rt 90 fd 40 rt 90 fd 20 rt 90 fd 20 rt 90 fd 40 rt 90 fd 10 rt 90 fd 10
rt 90 fd 20
end
to shape4
pu setpos [-10 -20] pd
repeat 4 [shape]
end
to crystal
setpos [0 10]
shape left 45 fd 70
crystal
end
to jengu
setpos [-20 0]
shape shape lt 90 jengu
end
to rsquare :size
repeat 4 [fd :size right 90]
end
to spinsquares :size
rsquare :size
rt 20
spinsquares :size
end
to growsquares :size
rsquare :size
rt 20
growsquares :size + 5
end
to rectangle :length :width
fd :length rt 90
fd :width rt 90
fd :length rt 90
fd :width rt 90
end
to flower
rectangle 100 20
rt 20
rectangle 10 40
rt 20
flower
end
to poly :side :angle
fd :side
rt :angle
poly :side :angle
end
to polystep :side :angle
fd :side
rt :angle
end
to twopoly :side1 :angle1 :side2 :angle2
polystep :side1 :angle1
polystep :side2 :angle2
twopoly :side1 :angle1 :side2 :angle2
end
to polyspiral :side :angle :inc
polystep :side :angle
polyspiral (:side + :inc) :angle :inc
end
to inspi :side :angle
polystep :side :angle
inspi :side (:angle + 10)
end
to csq
ht
setpc - 1
setbg 0
cs
repeat 10000
[repeat 16
[rsquare 80 rt 17 setpc 1]
setbg bg + 1]
end
to gsq :a
local "s
make "s 8
setpc - 1
setbg 0
cs
repeat 10000
[repeat 16
[repeat 4
[forward :s
right 90]
right :a
setpc 1
make "s :s + 1]
setbg bg + 1]
end
to gsq1 :a
(local "s "c)
make "s 8
make "c 0
setpc - 1
setbg :c
cs hideturtle
repeat 10000
[repeat 15
[penup
setpos [0 0]
pendown
repeat 4
[forward :s
right 90]
right :a
setpc 1
make "s :s + 1]
make "c :c + 15
if :c > 63 [make "c :c - 64 + 1]
[] setbg :c]
end
to ls :a
(local "s "c)
make "s 8
make "c 0
setpc - 1
setbg :c
cs hideturtle
repeat 10000
[repeat 16
[penup
setpos [0 0]
pendown
fd :s
right :a
setpc pencolor - 1
if :s < 200 [make "s :s + 1]
[]] make "c :c + 16
if :c > 63 [make "c :c - 64 + 1]
[] setbg :c]
end
to runner :name
clrs
ipr (list "procedure: :name)
pr []
po first :name
pr []
delay
run :name
end
to delay2
repeat 2 [repeat 32000 []]
end
to pencolor
op item 5 tf
end
to bg
op item 1 sf
end
UJACK Draws the British flag ("Union Jack")
to box :c1 :vt :hz
pu setpos :c1 pd seth 0
fd :vt rt 90 fd :hz rt 90 fd :vt rt 90 fd :hz rt 135
pu fd 4 pd fill pu bk 4 lt 45
end
to trap :c1 :c2 :y :ih
(local "q "h "d "xcor "ycor)
pu setpos :c1 pd seth :ih
fd :y make "q pos bk :y
make "h towards :c2
make "xcor xcor - first :c2
make "ycor ycor - last :c2
make "d sqrt (:xcor * :xcor + :ycor * :ycor)
setpos :c2
fd :y setpos :q pu
bk :y / 2 seth :h fd :d / 2 pd fill pu
end
to union.jack
setres 0 cs setbg 1 fs ht window
pu setpos [-160 -100]
setpc 3 pd repeat 2 [fd 199 rt 90 fd 319 rt 90]
box [-160 -30] 60 130
box [-30 -100] 200 60
box [30 -30] 60 130
trap [10 30] [140 100] 60 90
trap [10 -30] [140 -100] 60 90
trap [-10 30] [-140 100] 60 -90
trap [-10 -30] [-140 -100] 60 -90
setpc 2
box [-160 -20] 40 140
box [-20 -100] 200 40
box [20 -20] 40 140
trap [30 30] [160 100] 20 90
trap [30 -30] [160 -100] 20 90
trap [-30 30] [-160 100] 20 -90
trap [-30 -30] [-160 -100] 20 -90
end
USFLAG Draws the US flag
to box :ht :wt :c
if :c = 0 [setpc 15] [setpc :c] pd
repeat 2 [fd :ht rt 90 fd :wt rt 90] pu
if :c > 0 [rt 45 fd 4 pd fill pu bk 4 lt 45]
end
to flag
setres 0 fs window
cs setbg 1 ht
pu setpos [-134 1] box 98 120 0 fd 84 rt 90 fd 120 lt 90
repeat 3 [box 14 150 2 bk 14 box 14 150 3 bk 14] box 14 150 2
lt 90 fd 120 rt 90 bk 14 repeat 3 [box 14 270 3 bk 14 box 14 270 2 bk 14]
pu fd 103 rt 90 fd 5 lt 90 setpc 3
repeat 5 [star 5 star 4] star 5
end
to flagjr
setres 2 fs window cs setbg 49 ht
pu setpos [-134 1] box 98 120 0 fd 84 rt 90 fd 120 lt 90
repeat 3 [box 14 150 4 bk 14 box 14 150 15 bk 14] box 14 150 4
lt 90 fd 120 rt 90 bk 14 repeat 3 [box 14 270 15 bk 14 box 14 270 4 bk 14]
pu fd 103 rt 90 fd 5 lt 90 setpc 15
repeat 5 [star 5 star 4] star 5
end
to star :n
repeat :n
[rt 18 pd repeat 5 [fd 4 lt 72 fd 4 rt 144] lt 18
pu fd 5 rt 90 fd 5 pd fill pu bk 5 lt 90 fd 15]
bk 90 rt 90 fd 10 lt 90
end
TARDIS Time Travel Capsule of English TV series "Dr. Who"
to box :x :y
fd :y rt 90 fd :x rt 90
fd :y rt 90 fd :x rt 90 pu
end
to doors
fr 2.17 fl 2.17
pd box 31.13 148.42 pd box 28.96 146.25 rt 90 fl 3.62 fd 6.52
pd box 21.72 28.96 fd 35.48
pd box 21.72 28.96 fd 35.48
pd box 21.72 28.96 fd 35.48
pd box 21.72 28.96 pd box 21.72 14.48
rt 90 fl 7.24 pd box 7.24 28.96 rt 90 fl -7.24 fr -115.12 fl -5.79
fl 2.17 fr 2.17
pd box -31.13 148.42 pd box -28.96 146.25 lt 90 fr 3.62 fd 6.52
pd box -21.72 28.96 fd 35.48
pd box -21.72 28.96 fd 35.48
pd box -21.72 28.96 fd 35.48
pd box -21.72 28.96 pd box -21.72 14.48
lt 90 fr 7.24 pd box -7.24 28.96 lt 90 fr -7.24 fl -115.12 fr -5.79
end
to fl :n
fd :n lt 90
end
to fr :n
fd :n rt 90
end
to roof
setpos se (xcor + 28.84) (ycor + 6)
box 10.14 13.03 pd box 10.14 4.34
fr 4.34 fl 2.9 pd fd 6 bk 6 rt 90
fl 4.34 fd 6 bk 6 rt 90 fl 2.9 bk 4.34
setpos se (xcor + 28.84) (ycor - 6)
end
to tardis
setres 0 ht setpc 1 pu setpos [-66 -100] fs
pd box 97.74 5.79 fr 5.79 fl 2.9
pd box 91.95 170.14 rt 90 fl 46.34 doors
pu fl 150.59 fr 39.82
pd box 80.36 12.31 fr 5 fd 2 setpc 3
pd tt [Police box] pu setpc 1 fl -2 fl -5 fr 6.52
px box -2.9 10.86 fr 19.55 fl 12.31
pd box 67.33 4.34 fd 4.34 pd roof
pu rt 90 fr 12.31 fd 23.89 rt 180
px box 2.9 10.86 setx (xcor - 50.36) sety (ycor + 39.53)
pd loop [setpc 4 fill wait 2 setpc 15 fill wait 2]
end
to loop :body
label "loop
run :body
go "loop
end
THREED 3D Package from "Dr. Logo Newsletter #1"
to point :point_name :coords
make :point_name :coords
pprop :point_name "point "TRUE
pprop :point_name "orig :coords
end
to shape :shape_name :line_pairs
if (gprop :shape_name "point) = "TRUE [
(pr :shape_name [is already a point name.]) stop]
make :shape_name :line_pairs
pprop :shape_name "shape "TRUE
make "shapex (word :shape_name "_pts)
make :shapex []
make "n9 1
repeat count :line_pairs [
if not memberp first (item :n9 :line_pairs) thing :shapex [
make :shapex fput first (item :n9 :line_pairs) thing :shapex]
if not memberp last (item :n9 :line_pairs) thing :shapex [
make :shapex fput last (item :n9 :line_pairs) thing :shapex]
make "n9 :n9 + 1]
(pr :shape_name [is now a shape.])
end
to expand :shape :axis :amt
if not memberp :axis [x y z] [
pr [The axis must be "x, "y, or "z.] stop]
if not (gprop :shape "shape) = "TRUE [
(pr :shape [is not a shape.]) stop]
if :axis = "x [make "matrix (list :amt 0 0 0 1 0 0 0 1)]
if :axis = "y [make "matrix (list 1 0 0 0 :amt 0 0 0 1)]
if :axis = "z [make "matrix (list 1 0 0 0 1 0 0 0 :amt)]
draw :shape
end
to rotate :shape :axis :amt
if not memberp :axis [xy xz yz] [
pr [The axis must be "xy, "xz, or "yz.] stop]
if not (gprop :shape "shape) = "TRUE [
(pr :shape [is not a shape.]) stop]
if :axis = "xy [
make "matrix (list (cos :amt) 0 - (sin :amt) 0
(sin :amt) (cos :amt) 0
0 0 1)]
if :axis = "xz [
make "matrix (list (cos :amt) 0 0 - (sin :amt)
0 1 0
(sin :amt) 0 (cos :amt))]
if :axis = "yz [
make "matrix (list 1 0 0
0 (cos :amt) 0 - (sin :amt)
0 (sin :amt) (cos :amt))]
draw :shape
end
to magnify :shape :amt
if not (gprop :shape "shape) = "TRUE [
(pr :shape [is not a shape.]) stop]
make "matrix (list :amt 0 0 0 :amt 0 0 0 :amt)
draw :shape
end
to shear :shape :axis :amt
if not memberp :axis [x y] [
pr [The shear axis must be "x or "y.] stop]
if not (gprop :shape "shape) = "TRUE [
(pr :shape [is not a shape.]) stop]
if :axis = "x [make "matrix (list 1 :amt 0 0 1 0 0 0 1)] [
make "matrix (list 1 0 0 :amt 1 0 0 0 1)]
draw :shape
end
to restore :shape
if not (gprop :shape "shape) = "TRUE [
(pr :shape [is not a shape.]) stop]
make "n9 thing (word :shape "_pts)
repeat count :n9 [
make first :n9 gprop (first :n9) "orig
make "n9 bf :n9]
make "matrix [1 0 0 0 1 0 0 0 1]
draw :shape
end
to draw :shape
make "s9 thing (word :shape "_pts)
repeat count :s9 [
make "p9 first :s9
make :p9 (list
(item 1 :matrix) * (item 1 thing :p9) +
(item 2 :matrix) * (item 2 thing :p9) +
(item 3 :matrix) * (item 3 thing :p9)
(item 4 :matrix) * (item 1 thing :p9) +
(item 5 :matrix) * (item 2 thing :p9) +
(item 6 :matrix) * (item 3 thing :p9)
(item 7 :matrix) * (item 1 thing :p9) +
(item 8 :matrix) * (item 2 thing :p9) +
(item 9 :matrix) * (item 3 thing :p9))
make "s9 bf :s9]
make "s9 thing :shape
cs ht
repeat count :s9 [
pu setpos bl thing (first first :s9)
pd setpos bl thing (last first :s9)
make "s9 bf :s9]
end
to L
point "a [0 0 0]
point "b [50 0 0]
point "c [0 60 0]
point "d [0 60 20]
point "e [50 60 20]
point "f [50 60 0]
point "g [0 10 20]
point "h [50 10 20]
point "i [0 10 80]
point "j [0 0 80]
point "k [50 10 80]
point "l [50 0 80]
shape "L [[a b] [a c] [a j] [b f] [b l] [c d] [c f] [d g] [d e] [e f] [e h] [g
i] [g h] [h k] [i j] [i k] [j l] [k l]]
end
TOOLS Various useful routines
to circle :center :radius
; Draw a circle given a center [x y] and a radius
(local "p)
make "p pen
pu setpos :center
setx xcor - :radius
setpen :p
repeat 360 [fd 1 rt 1]
make "p pen
pu setpos :center
setpen :p
end
to erall.but :keeplist
; Erases all procedures not in the keeplist
(local "x "y "z)
make "x sort proclist
make "y :keeplist
make "z (if wordp :y [1] [count :y])
repeat :z [
make "x remove (if wordp :y [:y] [first :y]) :x
if not wordp :y [make "y bf :y]]
pr [These procedures will be erased:]
pr []
(pr :x)
pr []
pr [Is this what you want (y / n) ?]
if lc rc = "y [erase :x]
end
to inkey
; If a key has been pressed, return it, else return nothing
if keyp [op rc] [op []]
end
to intersection :set1 :set2
; Returns a list of the members of both set1 and set2
if or (emptyp :set1) (emptyp :set2) [op []]
if memberp (first :set1) :set2 [op (se first :set1 intersection (bf :set1)
:set2]
op intersection (bf :set1) :set2
end
to map :function :maplist
; Apply the function to each element of the maplist
if emptyp :maplist [op []]
op (se (run (list :function quote first :maplist)) (map :function bf
:maplist))
end
to remove :object :objlist
; Returns a list of objects with the specified object removed
(local "n "m)
if not memberp :object :objlist [op :objlist]
make "n where make "m count :objlist
if :n = 1 [op remove :object bf :objlist]
if :n = :m [op bl :objlist]
op remove :object (se piece 1 (:n - 1) :objlist piece (:n + 1) :m :objlist)
end
to reverse :set
; Returns a reversed copy of the input list
(local "x "n)
make "x []
make "n count :set
repeat count :set [
make "x (se :x item :n :set)
make "n :n - 1]
op :x
end
to strip.prop :x
; Removes all properties from the input name
(local "n "property)
make "n plist :x
if emptyp :n [stop]
make "property first :n
remprop :x :property
strip.prop :x
end
to union :set1 :set2
; Returns a list of the members of either set1 or set2
if emptyp :set1 [op :set2]
if memberp (first :set1) :set2 [op union bf :set1 :set2]
op union bf :set1 (se first :set1 :set2)
end
to unpkgall :set
; Unpackages all names in the input set
(local "x)
if emptyp :set [stop]
make "x :set
repeat count :set [remprop first :x ".PAK make "x bf :x]
end
to until :cond :body
; Perform the body until the condition is TRUE
label "loopst
run :body
if not run :cond [go "loopst]
end
to while :cond :body
; While the condition is TRUE, perform the body
label "loopst
if run :cond [run :body] [stop]
go "loopst
end
TOYBOX Various boards routines
to card_name :card
; The parameter is a 2-item list giving card value and suit
if or (first bf :card < 1) (first bf :card > 4) [op [Not a legal card]]
if or (first :card < 1) (first :card > 13) [op [Not a legal card]]
(pr item first :card [ace 2 3 4 5 6 7 8 9 10 jack queen king] "of
item last :card [hearts diamonds clubs spades])
end
to chess_board :x :y :sc
; Draws a chess board :x squares down by :y squares across of size :sc
(local "x1 "y1 "hz "vt "z "l "m)
make "hz :x * :sc make "vt :y * :sc make "x1 1 make "y1 :y
cs pu setpos (list :sc - 159 100) rt 90 pd
repeat 2 [fd :hz rt 90 fd :vt rt 90]
seth 0 sety ycor - :sc make "z 0
repeat :y [if :sc > 7 [
pu setx xcor - 8 fd 4 pd tt char (48 + :y1) make "y1 :y1 - 1
pu setx xcor + 8 pd bk 4]]
make "l ycor make "m :l + :sc
repeat :x [if :z = 0 [
repeat :sc / 2 [
pd sety :m setx xcor + 1 sety :l pu setx xcor + 1]
if (remainder :sc 2) = 1 [pd sety :m pu sety :l setx xcor + 1]] [
pu setx xcor + :sc]
make "z 1 - :z]
pu setx :sc - 159 sety ycor - :sc
if (remainder :x 2) = 0 [make "z 1 - :z]
if :sc > 7 [
pu fd :sc - 8 rt 90 fd 4 pd
repeat :x [tt char (96 + :x1) make "x1 :x1 + 1 pu fd :sc pd]]
end
to chip :size
(local "x)
if not memberp :size [2 4 5 6 8] [op [illegal size]]
make "x pos
repeat 72 [fd :size setpos :x rt 5]
end
to dice :num :sides
; Roll :num :sided dice (ex: 3d6 is dice 3 6)
local "total
make "total :num
repeat :num [make "total :total + random :sides]
op :total
end
to display_card :card :up
; Draws the specified card. Turtle starts in upper left corner.
(local "dcard "x "spot "value "suit)
if or (first bf :card < 1) (first bf :card > 4) [op [Not a legal card]]
if or (first :card < 1) (first :card > 13) [op [Not a legal card]]
make "value first :card
make "suit last :card
if or (:value < 1) (:value > 13) [stop]
if or (:suit < 1) (:suit > 4) [stop]
;
; --- Draw card border ---
;
ht setpc 3
pd repeat 2 [rt 90 fd 50 rt 90 fd 65] pu
if :up = "FALSE [stop]
make "x pos
if :value = 1 [make "dcard "a] [make "dcard :value]
if :value > 10 [make "dcard item (:value - 10) [j q k]]
make "spot char (:suit + 2)
;
; --- Display card value ---
;
tt_at 5 -6 :dcard tt_at (if :value = 10 [34] [42]) -60 :dcard setpos :x
;
; --- Fill in the spots ---
;
if :value = 10 [tt_at 24 -15 :spot tt_at 24 -55 :spot]
if memberp :value [2 3] [
tt_at 24 -25 :spot tt_at 24 -45 :spot]
if memberp :value [4 5 6 7] [
tt_at 8 -25 (list :spot "\ :spot) tt_at 8 -45 (list :spot "\ :spot)]
if memberp :value [8 9 10] [
tt_at 8 -25 (list :spot :spot :spot) tt_at 8 -45 (list :spot :spot :spot)]
if memberp :value [1 3 5 11 12 13] [tt_at 24 -35 :spot]
if memberp :value [6 8 10] [tt_at 8 -35 (list :spot "\ :spot)]
if memberp :value [7 9] [tt_at 8 -35 (list :spot :spot :spot)]
end
to draw_deck :suit
; Lets you see what all the cards look like. :suit should be 1 to 4.
(local "val)
make "val 1
cs pu setpos [-160 100]
repeat 2 [
repeat 6 [
display_card (list :val :suit) "TRUE
make "val :val + 1
rt 90 fd 50 lt 90]
pu setpos [-160 35]]
pu setpos [-160 -30]
display_card (list :val :suit) "TRUE
end
to get_random_seed
; Prevents games from always having the same random numbers
(local "x)
pr [Please press any key to start.]
label "loopst
make "x random 100 if not keyp [go "loopst] [make "x rc]
end
to go_board :x :y :sc
; Draws a go board :x squares down, :y squares across,
; with the squares size :sc
(local "hz "vt)
make "hz 100 - (:x * :sc)
make "vt (:y * :sc) - 160
window cs pu ht
setpos [-160 100] repeat :y + 1 [pd sety :hz sety 100 pu setx xcor + :sc]
setpos [-160 100] repeat :x + 1 [pd setx :vt setx -160 pu sety ycor - :sc]
end
to hex_board :sz :level
; Recursively draws a hexagon board
repeat 6 [
lt 30 fd :sz
if :level > 0 [lt 30 hex_board :sz :level - 1 rt 30]
rt 90]
end
to new_deck
; Fills deck with a shuffled deck of cards
make "deck shuffle [[1 1] [2 1] [3 1] [4 1] [5 1] [6 1] [7 1] [8 1] [9 1] [10
1] [11 1] [12 1] [13 1] [1 2] [2 2] [3 2] [4 2] [5 2] [6 2] [7 2] [8 2] [9 2]
[10 2] [11 2] [12 2] [13 2] [1 3] [2 3] [3 3] [4 3] [5 3] [6 3] [7 3] [8 3] [9
3] [10 3] [11 3] [12 3] [13 3] [1 4] [2 4] [3 4] [4 4] [5 4] [6 4] [7 4] [8 4]
[9 4] [10 4] [11 4] [12 4] [13 4]]
end
to sort.procs
(local "x)
make "x sort proclist
if (count :x) = 1 [stop]
repeat (count :x) - 1 [
(follow (first :x) (first bf :x))
make "x bf :x]
end
to splots
; Shows how CHIP can be used
cs setbg 16 window
label "splots
pu setpos (list (160 - random 320) (100 - random 200))
pd setpc 1 + random 3
chip item (1 + random 5) [2 4 5 6 8]
go "splots
end
to tt_at :dx :dy :txt
; Used by display_card
(local "x) make "x pos
pu setpos (list xcor + :dx ycor + :dy) tt :txt setpos :x
end
TRIG Display SIN and COS values
to trig
cs setbg 16 ht
pu setpos [-110 0] pd setpc 2
make "x 0
repeat 90 [
make "y 80 * cos :x setpc 2
fd :y bk :y
pu setx xcor + 1 pd
make "y 80 * sin :x setpc 1
fd :y bk :y
pu setx xcor + 1 pd
make "x :x + 4]
repeat 4 [setbg 2 wait 2 setbg 4 wait 2]
end
WEB Display a spider on a web
to cir :sz
quad :sz 36
end
to quad :s :n
repeat :n [fd :s rt 10]
end
to turtle :s
cir :s
quad :s 4 rt 180
cir :s * 0.3 rt 180
quad :s 5 rt 180
cir :s * 0.6 rt 180
quad :s 5 rt 180
cir :s * 0.3 rt 180
quad :s 4 quad :s 5 rt 180
cir :s * 0.3 rt 180
quad :s 4 quad :s 4 rt 180
cir :s * 0.3
end
to spider :s
cir :s lleg :s
quad :s 3 lleg :s
quad :s 6 rt 180 cir :s * 0.6 rt 180
quad :s 6 rleg :s
quad :s 3 rleg :s
quad :s 3 rleg :s
quad :s 12 lleg :s
end
to lleg :sz
lt 90 fd :sz * 5 lt 45 fd :sz * 5 bk :sz * 5 rt 45 bk :sz * 5 rt 90
end
to rleg :sz
lt 90 fd :sz * 5 rt 45 fd :sz * 5 bk :sz * 5 lt 45 bk :sz * 5 rt 90
end
to web :flg
; Usage: web 1
if :flg = 1 [
setbg 0
setsplit 4 splitscreen ct
cs setpc 15 ht
pu setpos [20 10] pd repeat 30 [lt 90 fd 14 bk 14 rt 102]]
pu setpos [6 10] pd make "s2 1.4142
repeat 30 [lt 60 fd :s2 lt 30 fd 14 bk 14 rt 150 fd :s2 lt 54 fd :s2 rt 6]
pu setpos [-8 10] pd make "s2 2.8284
repeat 30 [lt 60 fd :s2 lt 30 fd 14 bk 14 rt 150 fd :s2 lt 54 fd :s2 rt 6]
pu setpos [-22 10] pd make "s2 4.2426
repeat 30 [lt 60 fd :s2 lt 30 fd 14 bk 14 rt 150 fd :s2 lt 54 fd :s2 rt 6]
pu setpos [-36 10] pd make "s2 5.6568
repeat 30 [lt 60 fd :s2 lt 30 fd 14 bk 14 rt 150 fd :s2 lt 54 fd :s2 rt 6]
pu setpos [-50 10] pd make "s2 7.071
repeat 30 [lt 60 fd :s2 lt 30 fd 14 bk 14 rt 150 fd :s2 lt 54 fd :s2 rt 6]
ct pu setpos [-160 0] st seth 90
fd 20 lt 45 fd 15 rt 90 fd 40
seth 90 setx -100 seth 0 fd 5 seth 270 fd 3
seth 0 fd 5 sety 8 lt 45 fd 20 lt 45 fd 10 lt 45 fd 20
seth 0 fd 20 seth 90 repeat 10 [fd 3 rt 9] seth 90 fd 90 ht
setpc 1
pr ["Come into my parlor",]
pr [\ \ \ said the spider to the fly...]
wait 5
ct pr [Chomp!] ht seth 0 bk 2
pd spider 0.5
end
Maths
-----
DIFF Differential equation solver
to d :expr :var
make "expr (listw :expr)
make "expr (replace "\( "\[ :expr)
make "expr (replace "\) "\] :expr)
make "expr (wordl :expr)
op simp diff :expr :var
end
to diff :expr :x
(local "arg "arg1 "arg2 "opr)
if (count :expr) = 1 [make "expr first :expr]
if wordp :expr [if :expr = :x [op 1] [op 0]]
if (count :expr) = 2 [
make "opr item 1 :expr
make "arg item 2 :expr
if not memberp :opr [sin cos -] [(pr [Illegal expression:] :expr) stop]
if :opr = "sin [op (list (list "cos :arg) "\* diff :arg :x)]
if :opr = "cos [op (list (list 0 "\- (list "sin :arg)) "\* diff :arg :x)]
op (list 0 "\- diff :arg1 :x)]
if not (count :expr) = 3 [(pr [Illegal expression:] :expr) stop]
make "arg1 item 1 :expr
make "opr item 2 :expr
make "arg2 item 3 :expr
if memberp :opr [+ -] [op (list diff :arg1 :x :opr diff :arg2 :x)]
if :opr = "\* [
op (list (list :arg1 "\* diff :arg2 :x) "\+
(list :arg2 "\* diff :arg1 :x))]
if :opr = "\/ [
op (list (list (list :arg2 "\* diff :arg1 :x) "\-
(list :arg1 "\* diff :arg2 :x)) "\/ (list :arg2 "\* :arg2))]
if :opr = "\^ [
op (list (list :arg2 "\* (list :arg1 "\^ (list :arg2 "\- 1))) "\* diff
:arg1 :x)]
(pr [Unknown operator in:] :expr)
end
to end.word
if not emptyp :w [make "l lput :w :l make "w char 0]
end
to listw :objlist
; Change a list into a word
if wordp :objlist [op :objlist]
(local "m "n)
make "m 1 make "n "\[
repeat count :objlist [
make "n (word :n (listw item :m :objlist) (char 32)) make "m :m + 1]
op (word (bl :n) "\])
end
to replace :old :new :in
(local "q)
make "q char 0
repeat count :in [
make "q lput (if :old = first :in [:new] [first :in]) :q
make "in bf :in]
op :q
end
to simp :expr
(local "old "new)
make "old :expr
label "s
make "new simplify :old
if not (:new = :old) [make "old :new go "s]
op :new
end
to simplify :expr
(local "arg1 "arg2 "opr)
if (wordp :expr) [op :expr]
if (count :expr) = 2 [
make "opr item 1 :expr
make "arg1 item 2 :expr
if not memberp :opr [sin cos] [(pr [Illegal expression:] :expr) stop]
if numberp :arg1 [op run :expr] [op (list :opr simplify :arg1)]]
if not (count :expr) = 3 [(pr [Illegal expression:] :expr) stop]
make "arg1 item 1 :expr
make "opr item 2 :expr
make "arg2 item 3 :expr
if and (numberp :arg1) (numberp :arg2) [op run :expr]
if :opr = "\+ [
if :arg1 = 0 [op simplify :arg2]
if :arg2 = 0 [op simplify :arg1]
op (list simplify :arg1 "\+ simplify :arg2)]
if :opr = "\- [
if :arg2 = 0 [op simplify :arg1]
op (list simplify :arg1 "\- simplify :arg2)]
if :opr = "\* [
if or (:arg1 = 0) (:arg2 = 0) [op 0]
if :arg1 = 1 [op simplify :arg2]
if :arg2 = 1 [op simplify :arg1]
op (list simplify :arg1 "\* simplify :arg2)]
if :opr = "\/ [
if :arg1 = 0 [op 0]
if :arg2 = 1 [op simplify :arg1]
op (list simplify :arg1 "\/ simplify :arg2)]
if :opr = "\^ [
if :arg2 = 0 [op 1]
if :arg2 = 1 [op simplify :arg1]
op (list simplify :arg1 "\^ simplify :arg2)]
(pr [Unknown operator in:] :expr)
end
to sub.list
(local "l "w "c)
make "l [] make "w char 0
label "sloop
make "c first :object
if count :object > 1 [make "object bf :object] [make "object char 0]
if :c = "\[ [end.word make "l lput sub.list :l] [
if :c = "\] [end.word op :l] [
if memberp :c [() \; = < > + - * / ^ \ ] [
end.word if not (:c = "\ ) [make "w :c end.word]] [
make "w (word :w :c)]]]
if not emptyp :object [go "sloop]
end.word op :l
end
to wordl :object
; Converts a word into a list
(local "l)
make "l sub.list
if (count :l) = 1 [if listp (first :l) [make "l first :l]]
op :l
end
Utility
-------
DR2 Procedures emulating some Dr. Logo Version 1 primitives
to bg
op first sf
end
to pc
op item 5 tf
end
to pen
op piece 4 5 tf
end
to shownp
op last tf
end
to sp :pal
(local "bg)
make "bg remainder (first sf) 16
if :pal > 2 [make "bg :bg + 16 make "pal :pal - 3]
if :pal > 0 [make "bg :bg + 32]
setbg :bg
end
to textbg :n
end
to textfg :n
end
MERGE Mail merge printing of addresses
to align :entry
if "\[ = (first :entry) [make "entry bf :entry]
if "\] = (last :entry) [make "entry bl :entry]
if :width <= count :entry [op piece 1 :width :entry]
op (word :entry piece 1 (:width - (count :entry)) "\ \ \ \ \ \ \ \ \ \ \ \ \ \
\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ )
end
to listw :objlist
; Change a list into a word
if wordp :objlist [op :objlist]
(local "m "n)
make "m 1 make "n "\[
repeat count :objlist [
make "n (word :n (listw item :m :objlist) (char 32)) make "m :m + 1]
op (word (bl :n) "\])
end
to mailing.labels :names
label "ml.a
type [How many spaces across per label? (default is 20)]
make "width rq
if emptyp :width [make "width 20]
if not numberp :width [pr [* * * Please enter a number] go "ml.a]
label "ml.b
type [How many labels across? (default is 4)]
make "across rq
if emptyp :across [make "across 4]
if not numberp :across [pr [* * * Please enter a number] go "ml.b]
label "ml.c
type [How many blank lines after each label? (default is 0)]
make "blanks rq
if emptyp :blanks [make "blanks 0]
if not numberp :blanks [pr [* * * Please enter a number] go "ml.c]
open :names setread :names
if readeofp [pr [* * * Invalid namelist file] closeall stop]
make "template rl
if memberp "@fname :template [make "fname where]
if memberp "@lname :template [make "lname where]
if memberp "@address :template [make "address where]
if memberp "@city :template [make "city where]
if memberp "@state :template [make "state where]
if memberp "@zip :template [make "zip where]
if memberp 0 (list :fname :lname :address :city :state :zip)
[pr [* * * Invalid namelist file] closeall stop]
make "file.done "FALSE
label "ml.d
make "name.field char 0 make "address.field char 0
make "city.field cahr 0 make "n :width
repeat :across [
if readeofp [make "file.done "TRUE go "ml.e]
make "record rl
make "name.field
(word :name.field align (word (item :fname :record) (item :lname :record))
make "address.field
(word :address.field align (listw (item :address :record)))
make "city.field
(word :city.field align (word listw (item :city :record) ",\
(item :state :record) "\ (item :zip :record))]
label "ml.e
pr :name.field
pr :address.field
pr :city.field
repeat :blanks [pr []]
if not :file.done [go "ml.d]
closeall
end
to replace2 :old :new :rtext
; Replace the old text with the new text at any level
if :rtext = [] [op []]
if :old = :rtext [op :new] [
if wordp :rtext [op :rtext] [
op fput (replace2 :old :new first :rtext) (replace2 :old :new bf
:rtext)]]
end
to send :letter :names
open :letter setread :letter
make "txt []
while [not readeofp] [make "txt lput rl :txt]
closeall
open :names setread :names
if readeofp [pr [Invalid file contents] closeall stop]
make "template rl
setwrite "prn:
while [not readeofp] [
make "fill.ins rl make "f :fill.ins make "t :template
make "expanded :txt
repeat count :template [
if emptyp :f [closeall (pr [Invalid name record:] :fill.ins) stop]
make "expanded replace2 (first :t) (first :f) :expanded
make "t bf :t make "f bf :f]
make "expanded replace2 "\\ (char 9) :expanded
repeat count :expanded [pr (first :expanded) make "expanded bf :expanded]
pr (char 12)] ; Form Feed
closeall
end
to while :cond :body
label "while
if not (run :cond) [stop]
run :body
go "while
end
NSQRT New square root routine
to nsqrt :num
local "x
if :num <= 0 [op 0]
make "x :num * 0.5 + 0.5
repeat 9 [make "x ((:num / :x) + :x) * 0.5]
op :x
end
TELL Tell the various properties of a procedure
tell "star ; from USflag.log
STAR is not in a package.
Procedure contents:
to star :n
repeat :n
[rt 18 pd repeat 5 [fd 4 lt 72 fd 4 rt 144] lt 18
pu fd 5 rt 90 fd 5 pd fill pu bk 5 lt 90 fd 15]
bk 90 rt 90 fd 10 lt 90
end
References to it:
to flagjr
to flag
Calls it makes:
star :n
Properties of STAR:
.FMT [[2 .SPC . 2] [20 .SPC . 3]]
to tell :n
local "x
make "x gprop :n ".PAK
pr []
if (:x = [])
[(pr uc :n [is not in a package.])]
[(pr uc :n [is in package:] uc :x)]
if definedp :n
[pr []
pr [Procedure contents:]
pr []
po :n
pr [References to it:]
pr []
poref :n
pr []
pr [Calls it makes:]
pr []
pocall :n
pr []]
if memberp ".APV plist :n
[pr []
pr [Variable value:]
pr []
pr thing :n
pr []]
pr []
(pr [Properties of] word uc :n ":)
pr []
printprops plist :n
pr []
end
to printprops :n
if :n = []
[stop]
if not memberp first :n [.DEF .PAK .APV]
[(pr piece 1 2 :n)]
printprops bf bf :n
end
TOOLBX1 Improved from the Dr. Logo Newsletter #1
to apply :function# :maplist#
; Apply the function# to each element of the maplist# (returns nothing)
if emptyp :maplist# [stop]
run (list :function# :maplist#)
apply :function# bf :maplist#
end
to arc.l :center :radius :angle
; Draws a left arc given center [x y], radius, and arc's angle
(local "p "amt)
make "p pen make "amt :radius * 1.75E-002 ; Pi / 180
pu setpos :center fd :radius lt 90 setpen :p
repeat :angle [fd :amt lt 1]
pu rt 90 bk :radius setpen :p
end
to arc.r :center :radius :angle
; Draws a right arc given center [x y], radius, and arc's angle
(local "p "amt)
make "p pen make "amt :radius * 1.75E-002 ; Pi / 180
pu setpos :center fd :radius rt 90 setpen :p
repeat :angle [fd :amt rt 1]
pu lt 90 bk :radius setpen :p
end
to ask :question
; Returns a user response to a question
(type :question)
op first readlist
end
to askyn :question
; Returns TRUE if user answers question yes
(local "ans)
(type :question)
make "ans rc
(pr :ans)
op :ans = "y
end
to circle :center :radius
; Draws a circle given a center [x y] and a radius
(local "p "amt)
make "p (piece 3 5 tf)
make "amt :radius * 1.75E-002 ; Pi / 180
pu setpos :center setx xcor - :radius seth 0 setpen bf :p
repeat 360 [fd :amt rt 1]
pu setpos :center setpen bf :p seth first :p
end
to cond :condlist#
; Returns the result paired with the first test that returns TRUE.
; Format of :condlist# is [test1 result1 test2 result2 ...]
(local "cl#)
if (remainder (count :condlist#) 2) > 0 [op [condlist unbalanced]]
make "cl# :condlist#
label "loopst
if emptyp :cl# [stop]
if run first :cl# [run first bf :cl# stop]
make "cl# bf bf :cl#
go "loopst
end
to delete :object :objlist
; Delete first occurence of object from the objlist
if not memberp :object :objlist [op :objlist]
if emptyp :object [op []]
if :object = first :objlist [op bf :objlist]
op fput first :objlist delete :object bf :objlist
end
to drop.props :properties
(local "x "prop)
make "properties (se :properties)
repeat count :properties [
make "prop first :properties
(make "x glist :prop)
repeat count :x [
remprop (first :x) :prop
make "x bf :x]
make "properties bf :properties]
end
to every :objlist# :predicate#
; Returns "TRUE if predicate is true of every element of in objlist.
repeat count :objlist# [
if not run (se :predicate# "first (list :objlist#)) [op "FALSE]
make "objlist# bf :objlist#]
op "TRUE
end
to filled_cir :center :radius
; Draws a solid circle given a center [x y] and a radius
(local "p "amt)
make "p (piece 3 5 tf)
make "amt :radius * 1.75E-002 ; Pi / 180
pu setpos :center setx xcor - :radius seth 0 setpen bf :p
repeat 360 [fd :amt rt 1]
pu setpos :center setpen bf :p seth first :p fill
end
to filled_pie :center :radius :angle
; Draws a pie slice given center [x y], radius, and slice's angle
(local "p "amt)
make "p pen
make "amt :radius * 1.75E-002 ; Pi / 180
pu setpos :center setpen :p
fd :radius rt 90
repeat :angle [fd :amt rt 1]
lt 90 bk :radius
pu lt :angle / 2 fd :radius / 2 setpen :p fill
pu bk :radius / 2 rt :angle / 2 setpen :p
end
to forget :object
; Removes all properties from the input object
if (se :object) = [forget] [stop]
repeat (count plist :object) / 2 [remprop :object first plist :object]
end
TOOLBX2 Improved from the Dr. Logo Newsletter #1
to string :sz :offset :halves
; usage: string 98 2 2
(local "n "o "p "q)
make "o pi / 180
clean ht make "p pos pu setx xcor + :sz pd
repeat 360
[fd :sz * :o lt 1]
pu setpos :p make "n 1
repeat 36 * :halves
[pu fd :sz make "q pos
setpos :p seth remainder (5 * :n * :offset) 360
fd :sz pd setpos :q pu
setpos :p seth remainder (5 * (:n - 1)) 360
make "n :n + 1]
end
to cascade
make "sqr2 sqrt 2
setbg 16 fullscreen
cs ht pu setpos [-70 -85] pd
make "x xcor make "y ycor
list
(local "locs "l)
make "locs [] make "l 1
repeat count :objlist [
if (item :l :objlist) = :object [make "locs lput :l :locs]
make "l :l + 1]
op :locs
end
to lprint :object
; Print the object on the printer
copyon
(pr :object)
copyoff
end
to lshow :object
; Show the object on the printer
copyon
(show :object)
copyoff
end
to ltype :object
; Type the object on the printer
copyon
(type :object)
copyoff
end
to min.max :objlist
; Returns the smallest and largest numbers in a list
make "objlist sort :objlist
op list first :objlist last :objlist
end
to polar.rect :coords
; Converts polar coordinates into rectangular coordinates
(local "p "theta)
make "p first :coords make "theta last :coords
op (list :p * cos :theta :p * sin :theta)
end
to prime? :n
; Tells if a number is prime
(local "i "l "m)
if not (:n = int :n) [op "FALSE] if :n < 4 [op "TRUE]
if or (0 = (remainder :n 2)) (0 = (remainder :n 3)) [op "FALSE]
make "i 5 make "m 2 make "l sqrt :n if :l = int :l [op "FALSE]
repeat 1 / 0 [if 0 = (remainder :n :i) [op "FALSE] if :i > :l [op "TRUE] make
"i :i + :m make "m if :m = 2 [4] [2]]
end
to randomize
; Used to scramble random number sequences
(local "x)
pr [Press any key to continue.]
label "r
if not keyp [make "x random 10 go "r]
make "x rc
end
to rect.polar :coords
; Converts rectangular coordinates into polar coordinates
(local "x "y)
make "x first :coords make "y last :coords
op (list sqrt (:x * :x + :y * :y) arctan (:y / :x))
end
to rename :old.name :new.name
; Renames a user-defined procedure
if not definedp :old.name [
(pr [Not a procedure:] :old.name) stop]
if or (not wordp :new.name) (numberp :new.name) [
(pr [Not a valid name:] :new.name) stop]
copydef :new.name :old.name
erase :old.name
end
to replace2 :old :new :rtext
; Replace the old text with the new text at any level
if :rtext = [] [op []]
if :old = :rtext [op :new] [
if wordp :rtext [op :rtext] [
op fput (replace2 :old :new first :rtext) (replace2 :old :new bf
:rtext)]]
end
to root :base :num
; Computes the :base-th root of a number
(local "x "n1)
if :num = 0 [op 0]
if :num < 0 [op "nan]
make "x :num make "n1 :base - 1
repeat 10 [make "x ((:num / (:x ^ :n1)) + :n1 * :x) / :base]
op :x
end
TOOLBX3 Improved from the Dr. Logo Newsletter #1
to reverse :set
; Returns a reversed copy of the input list
if count :set < 2 [op :set]
op (se (list last :set) reverse bl :set)
end
to rise :object#
; Allow commands to be used where functions are needed
(local "y##)
catch "error [(make "y## run (se :object#)) op :y##]
make "y## error
if (first :y##) = 42 [op []]
(pr (item 2 :y##))
throw "toplevel
end
to sink :object
; Allows functions to be used where commands are needed
end
to some :objlist# :predicate#
; Return TRUE if predicate is true of some element of objlist.
repeat count :objlist# [
if run (se :predicate# "first (list :objlist#)) [op "TRUE]
make "objlist# bf :objlist#]
op "FALSE
end
to sort.procs
(local "x)
make "x sort proclist
if count :x = 1 [stop]
repeat (count :x) - 1 [
(follow (first :x) (first bf :x))
make "x bf :x]
end
to subset :objlist# :predicate#
; Output those elements of objlist for which the predicate is TRUE.
(local "x##)
if emptyp :objlist# [op []]
make "x## []
repeat count :objlist# [
if run (se :predicate# "first (list :objlist#)) [
make "x## lput first :objlist# :x##]
make "objlist# bf :objlist#]
op :x##
end
to union :set1 :set2
; Returns a list of the members of either set1 or set2
if emptyp :set1 [op :set2]
if memberp (first :set1) :set2 [op union bf :set1 :set2]
op union bf :set1 (se (list first :set1) :set2)
end
to unpkgall :set
; Unpackages all names in the input set
if emptyp :set [stop]
make "set :set
repeat count :set [remprop first :set ".PAK make "set bf :set]
end
to until :cond# :body#
; Perform the body until the condition is TRUE
label "loopst
run :body#
if not run :cond# [go "loopst]
end
to uses
; Shows which procedures use other procedures
(local "x "y)
make "x sort proclist
repeat count :x [
pocall first :x
make "x bf :x
pr []
if not emptyp :x [make "y rc pr []]]
end
to verall
(local "x "y)
make "x sort proclist
make "y []
pr []
repeat count :x [
type (se [Erase] uc first :x [\ (y / n) ?\ ])
if "y = rc [pr [y] make "y lput (first :x) :y] [pr [n]]
make "x bf :x]
pr [] pr [These procedures will be erased:] pr []
pr :y pr []
type [Is this what you want (Y\/N) ?\ ]
if "y = rc [pr [y] er :y] [pr [n]]
end
to while :cond# :body#
; While the condition is TRUE, perform the body
label "loopst
if run :cond# [run :body#] [stop]
go "loopst
end
TOOLBX4 Improved from the Dr. Logo Newsletter #1
to array :a.name :a.dim
; Create a named array
(local "n "p "d)
make "n 1 make "p [] make "d (se "op "\( "word (word "" :a.name))
repeat :a.dim [
make "p (se :p (word "n :n))
make "d (se :d ""_ (word ":n :n))
make "n :n + 1]
define :a.name list :p (lput "\) :d)
end
to assoc :object :objlist
; Search a list of two item lists for a match against the first item
if :objlist = [] [op []] [
if :object = (first first :objlist) [op first :objlist] [
op assoc :object bf :objlist]]
end
to cur.tur :position
; Converts a cursor position into a turtle position
op list ((first :position) - 20) * 8 (12.5 - (last :position)) * 8
end
to delta :c#1 :c#2
; Returns a list of the changes in x and y between the 2 coordinate pairs
op (list (first :c#2) - (first :c#1) (last :c#2) - (last :c#1))
end
to depth :objlist#
; Returns the maximum nesting level in the object list
(local "n "m)
if emptyp :objlist# [op 1]
if wordp :objlist# [op 0]
make "n depth first :objlist#
make "m (depth bf :objlist#) - 1
if :n < :m [op 1 + :m] [op 1 + :n]
end
to explode :object#
; Turn a word into a list of characters
if listp :object# [op :object#]
(local "x)
make "x []
repeat count :object# [
make "x lput first :object# :x
make "object# bf :object#]
op :x
end
to factors :num
; Returns a list of the prime factors of a number
(local "f "q "s)
make "f [] make "s :num make "q 2
label "a
if (remainder :num :q) = 0 [make "f lput :q :f]
label "b
if (remainder :num :q) = 0 [make "num :num / :q go "b]
make "q :q + 1
if not (:q > :num) [go "a]
if :f = [] [make "f (list :s)]
op :f
end
to flatten :objlist
; Remove all inner brackets in a list
if wordp :objlist [op :objlist]
(local "m "n)
make "m 1 make "n []
repeat count :objlist [make "n se :n (flatten item :m :objlist) make "m :m +
1]
op :n
end
to flush.buffer
; Removes unwanted keystrokes from the buffer
local "x
label "flush
if keyp [make "x rc go "flush]
end
to for :loop.parts# :stmt#
; Simulates C's FOR construct
run (item 1 :loop.parts#)
label "for.loop
if run (item 2 :loop.parts#) [stop]
run :stmt#
run (item 3 :loop.parts#)
go "for.loop
end
to freq :obj :objlist
; Reports the number of times an object appears in a list
local "n
make "n 0
repeat count :objlist [
if :obj = first :objlist [make "n :n + 1]
make "objlist bf :objlist]
op :n
end
to gcd :num1 :num2
; Returns the Greatest Common Denominator of the two numbers
(local "r)
label "loopst
make "r remainder :num1 :num2
if :r = 0 [op :num2]
make "num1 :num2
make "num2 :r
go "loopst
end
to hex :object
; Returns the decimal value of a hexadecimal number
(local "n "m)
make "n 0 make "m :object
repeat count :m [
if memberp uc (first :m) [0 1 2 3 4 5 6 7 8 9 A B C D E F] [
make "n :n * 16 + where - 1] [
(pr :object [isn't a hexadecimal number.]) op -1]
make "m bf :m]
op :n
end
to implode :objlist
; Turn a list of atoms into a word
if wordp :objlist [op :objlist]
(local "x)
make "x "
repeat count :objlist [
make "x lput first :objlist :x
make "objlist bf :objlist]
op :x
end
TOOLBX5 Improved from the Dr. Logo Newsletter #1
to in? :object :objlist
; Tests to see if the object is within the object list at any level
if :objlist = [] [op "FALSE]
if :object = :objlist [op "TRUE] [
if wordp :objlist [op "FALSE] [
if in? :object (first :objlist) [op "TRUE] [
op in? :object (bf :objlist)]]]
end
to lcm :num1 :num2
; Returns the Least Common Multiple of the two numbers
op (:num1 * :num2) / (gcd :num1 :num2)
end
to locations :object :objlist
; Returns a list of the locations of the object in the object list
(local "locs "l)
make "locs [] make "l 1
repeat count :objlist [
if (item :l :objlist) = :object [make "locs lput :l :locs]
make "l :l + 1]
op :locs
end
to lprint :object
; Print the object on the printer
copyon
(pr :object)
copyoff
end
to lshow :object
; Show the object on the printer
copyon
(show :object)
copyoff
end
to ltype :object
; Type the object on the printer
copyon
(type :object)
copyoff
end
to min.max :objlist
; Returns the smallest and largest numbers in a list
make "objlist sort :objlist
op list first :objlist last :objlist
end
to polar.rect :coords
; Converts polar coordinates into rectangular coordinates
(local "p "theta)
make "p first :coords make "theta last :coords
op (list :p * cos :theta :p * sin :theta)
end
to prime? :n
; Tells if a number is prime
(local "i "l "m)
if not (:n = int :n) [op "FALSE] if :n < 4 [op "TRUE]
if or (0 = (remainder :n 2)) (0 = (remainder :n 3)) [op "FALSE]
make "i 5 make "m 2 make "l sqrt :n if :l = int :l [op "FALSE]
loop [if 0 = (remainder :n :i)
[op "FALSE] if :i > :l [op "TRUE] make "i :i + :m make "m if :m = 2 [4] [2]]
end
to randomize
; Used to scramble random number sequences
(local "x)
pr [Press any key to continue.]
label "r
if not keyp [make "x random 10 go "r]
make "x rc
end
to rect.polar :coords
; Converts rectangular coordinates into polar coordinates
(local "x "y)
make "x first :coords make "y last :coords
op (list sqrt (:x * :x + :y * :y) arctan (:y / :x))
end
to rename :old.name :new.name
; Renames a user-defined procedure
if not definedp :old.name [
(pr [Not a procedure:\ ] :old.name) stop]
if or (not wordp :new.name) (numberp :new.name) [
(pr [Not a valid name:\ ] :new.name) stop]
copydef :new.name :old.name
erase :old.name
end
to replace2 :old :new :rtext
; Replace the old text with the new text at any level
if :rtext = [] [op []]
if :old = :rtext [op :new] [
if wordp :rtext [op :rtext] [
op fput (replace2 :old :new first :rtext) (replace2 :old :new bf
:rtext)]]
end
to root :base :num
; Computes the :base-th root of a number
(local "x "n1)
if :num = 0 [op 0]
if :num < 0 [op "nan]
make "x :num make "n1 :base - 1
repeat 10 [make "x ((:num / (:x ^ :n1)) + :n1 * :x) / :base]
op :x
end
TOOLBX6 Improved from the Dr. Logo Newsletter #1
to day
pr [Day is ended]
play [E E B' B' F# G F# E] [270 180 360 180 270 90 90 360]
play [D E E D' D' C#' B' A' B'] [90 270 180 360 180 270 90 90 360]
play [E E D' D' C#' B' A' B'] [180 180 360 180 270 90 90 180]
play [E E B' A' G F# E D E] [90 270 180 360 180 270 90 90 360]
end
to day2
pr [Day is ended]
play [E E B' B' F# G F# E] [27 18 36 18 27 9 9 36]
play [D E E D' D' C#' B' A' B'] [9 27 18 36 18 27 9 9 36]
play [E E D' D' C#' B' A' B'] [18 18 36 18 27 9 9 18]
play [E E B' A' G F# E D E] [9 27 18 36 18 27 9 9 36]
end
to end.word
if not emptyp :w [make "l lput :w :l make "w char 0]
end
to listw :objlist
; Change a list into a word
if wordp :objlist [op :objlist]
(local "m "n)
make "m 1 make "n "\[
repeat count :objlist [
make "n (word :n (listw item :m :objlist) (char 32)) make "m :m + 1]
op (word (bl :n) "\])
end
to play :notes :times
pr :notes repeat count :notes [tones list thing (first :notes) (first :times)
make "notes bf :notes make "times bf :times]
end
to rotate :object :dir
; Rotate the object's elements. + :dir rotates right; - :dir rotates left
if :dir > 0 [repeat :dir [make "object fput (last :object) (bl :object)]]
if :dir < 0 [repeat abs :dir [make "object lput (first :object) (bf :object)]]
op :object
end
to rpall :props
; Removes properties from all atoms that have them
(local "vars "p)
make "props (se :props) ; Allows :props to be word or list
repeat count :props [
make "p (first :props)
make "props (bf :props)
make "vars (glist :p)
repeat count :vars [
remprop (first :vars) :p
make "vars bf :vars]]
end
to set.notes
; Initializes variables for play function
make "notes [A A# B C C# D D# E F F# G G# A' A#' B' C' C#' D' D#' E' F' F#' G'
G#' R]
make "freqs [440 466 494 523 554 587 622 659 698 740 784 831 880 934 988 1047
1111 1175 1247 1319 1397 1482 1568 1664 0]
repeat count :notes [make (first :notes) (first :freqs) make "notes bf :notes
make "freqs bf :freqs]
end
to sort.indx :objlist
; Returns a list of indexes to a list showing how sort would reorder them
(local "x "y)
make "x sort :objlist
make "y []
repeat count :x [
if memberp first :x :objlist [make "y lput where :y]
make "x bf :x]
op :y
end
to sub.list
(local "l "w "c)
make "l [] make "w char 0
label "sloop
make "c first :object
if count :object > 1 [make "object bf :object] [make "object char 0]
if :c = "\[ [end.word make "l lput sub.list :l] [
if :c = "\] [end.word op :l] [
if memberp :c [() \; = < > + - * / ^ \ ] [
end.word if not (:c = "\ ) [make "w :c end.word]] [
make "w (word :w :c)]]]
if not emptyp :object [go "sloop]
end.word op :l
end
to tab :n
; Types enough spaces to move the cursor to column :n
make "n :n - first cursor
if 0 < :n [repeat :n [type "\ ]]
end
to tur.cur :position
; Converts a turtle position into the closest cursor position
op list int ((first :position) / 8 + 20) int ((last :position) / 8 - 12.5)
end
to wordl :object
; Converts a word into a list
(local "l)
make "l sub.list
if (count :l) = 1 [if listp (first :l) [make "l first :l]]
op :l
end
to words? :objlist
; Tests to see if :objlist contains only words
if emptyp :objlist [op "TRUE]
if not wordp first :objlist [op "FALSE]
op words? bf :objlist
end
to xor :object1 :object2
; Returns the exclusive-or truth value of the two objects
op not (:object1 = :object2)
end
LOSHIFT Convert a file to lowercase
to loshift :fname
open :fname setread :fname
open "temp.log setwrite "temp.log
label "loopst
if not readeofp [pr lc rq go "loopst]
closeall
erasefile :fname
changef :fname "temp
end
UPSHIFT Convert a file to uppercase
to upshift :fname
open :fname setread :fname
open "temp.log setwrite "temp.log
label "loopst
if not readeofp [pr uc rq go "loopst]
closeall
erasefile :fname
changef :fname "temp
end
POFILE Display contents of a file
to pofile :fname
open :fname setread :fname
label "loopst
if readeofp [closeall stop]
show rq
go "loopst
end
UTILITY 4 workspace routines
to verall
(local "x "y)
make "x sort proclist
make "y []
pr []
repeat count :x [
type (se [Erase] uc first :x [(Y\/N) ?\ ])
if "y = rc [pr [y] make "y lput (first :x) :y] [pr [n]]
make "x bf :x]
pr [] pr [These procedures will be erased:] pr []
pr :y pr []
type [Is this what you want (Y\/N) ?\ ]
if "y = rc [pr [y] er :y] [pr [n]]
pr []
end
to cleanup
er [cleanup drop.props sort.procs verall]
end
to drop.props :properties
(local "x "prop)
make "properties (se :properties)
repeat count :properties [
make "prop first :properties
(make "x glist :prop)
repeat count :x [
remprop (first :x) :prop
make "x bf :x]
make "properties bf :properties]
end
to sort.procs
(local "x)
make "x sort proclist
if count :x = 1 [stop]
repeat (count :x) - 1 [
(follow (first :x) (first bf :x))
make "x bf :x]
end
XDIR Display the directory of a disk
xdir "a:
Directory of 69 files on disk in drive A:
ADV.LOG DRAW.LOG PATHS.LOG THREED.LOG XDIR.LOG
ANIMAL.LOG DRI.LOG PCHART.LOG TOOLBX1.LOG
AUSSIE.LOG DRLOGO.LOG PIE.LOG TOOLBX2.LOG
AUSSIE2.LOG DYNA.LOG POEM.LOG TOOLBX3.LOG
BARCHART.LOG ELIZA.LOG POEM2.LOG TOOLBX4.LOG
BCHART2.LOG FIGURE.LOG POFILE.LOG TOOLBX5.LOG
BFLY.LOG FRENCH.LOG POLAR.LOG TOOLBX6.LOG
BRAIDS.LOG GAGFILL.LOG QBERT.LOG TOOLS.LOG
CARDS.LOG HEART.LOG REVERSE.LOG TOYBOX.LOG
CP.LOG KEPLER.LOG ROLEPLAY.LOG TRIG.LOG
DDD.LOG LETTERS.LOG ROSE.LOG UJACK.LOG
DENNIS.LOG LOSHIFT.LOG SHAPES.LOG UPSHIFT.LOG
DESIGN.LOG MAZE.LOG STAR.LOG USFLAG.LOG
DIFF.LOG MERGE.LOG STRING.LOG UTILITY.LOG
DISCOVER.LOG MTURTLE.LOG STUFF.LOG VERALL.LOG
DR2.LOG MUSIC.LOG TARDIS.LOG WEB.LOG
DRAGON.LOG NSQRT.LOG TELL.LOG WEST.LOG
to xdir :dr
(local "c "l "n "d "sz "files)
setres 1
if count :dr = 0
[make "d defaultd]
[make "d :dr]
make "files sort dir uc :d
make "c 0 make "l 2 make "n 1 make "sz 1
ct (pr [Directory of] count :files [files on disk in drive] uc :d)
pr []
repeat count :files
[setcursor list :c :l (type item :sz :files)
make "n :n + 1 make "l :l + 1 make "sz :sz + 1
if :n = 18
[make "c :c + 15 make "l 2 make "n 1]]
setcursor [0 19]
pr []
end
Sound
-----
MUSIC Works on my 100-MHz PC
to stwars
pr [Theme from Star Wars]
play [C G R F E D C' G R F E D C' G R F E F D R] [18 18 9 9 9 9 18 18 9 9 9 9
18 18 9 9 9 18 9 45]
play [C G R F E D C' G R F E D C' G R F E F D R] [18 18 9 9 9 9 18 18 9 9 9 9
18 18 9 9 9 18 9 45]
play [A F R E D C C D E D A B] [9 18 9 9 9 45 45 9 9 9 13 9]
play [A F R E D C G D] [9 18 9 9 9 9 9 9]
play [A F R E D C C D E D A B] [9 18 9 9 9 45 45 9 9 9 135 9]
play [G G C' A#' G# G F D# D C G] [45 13 22 22 23 23 45 9 9 9 9]
end
to grest
pr [God rest ye merry gentlemen]
play [E E B' B' A' G F# E D E F# G A' B'] [9 9 9 9 9 9 9 9 9 9 9 9 9 18]
play [E E B' B' A' G F# E D E F# G A' B'] [9 9 9 9 9 9 9 9 9 9 9 9 9 18]
play [B' C' A' B' C' D' E' B' A' G E F# G A'] [9 9 9 9 9 9 9 9 9 9 9 9 9 18]
play [G A' B' C' B' B' A' G F# E] [9 9 22 9 9 9 9 9 9 9]
play [G F# E A'] [45 45 18 9]
play [G A' B' C' B' B' A' G F# E] [9 9 22 9 9 9 9 9 9 9]
end
to gking
pr [Good King Wenceslaus]
play [G G G A' G G D E D E F# G G] [9 9 9 9 9 9 18 9 9 9 9 18 9]
play [G G G A' G G D E D E F# G G] [9 9 9 9 9 9 18 9 9 9 9 18 9]
play [D' C' B' A' G G D E D E F# G G] [9 9 9 9 9 9 18 9 9 9 9 18 9]
play [D D E F# G G A' D' C' B' A' G C' G] [9 9 9 9 9 9 18 9 9 9 9 18 18 18]
end
to mack
pr [Mack the knife]
play [E G A' A'] [9 9 18 18]
play [E G A' A'] [9 9 18 18]
play [D F A' A'] [9 9 18 18]
play [C' B' A'] [9 9 18]
play [G B' D' C'] [9 9 18 18]
play [B' A' C' D] [9 9 18 18]
play [E F C' D] [9 9 18 18]
play [C' B' A'] [9 9 9]
end
to brain
pr [If I only had a brain]
play [E F G E C D E C] [9 9 18 9 18 9 18 9]
play [C D E C A B C A] [9 9 18 9 18 9 9 18]
play [E G G G G G] [45 9 45 9 45 18]
play [C B A A A' G F E] [9 9 18 45 18 9 45 45]
play [D C B B B' A' G F] [9 9 18 45 18 9 45 45]
play [E D C C C C C] [9 45 9 45 9 45 18]
end
to day
pr [Day is ended]
play [E E B' B' F# G F# E] [27 18 36 18 27 9 9 36]
play [D E E D' D' C#' B' A' B'] [9 27 18 36 18 27 9 9 36]
play [E E D' D' C#' B' A' B'] [18 18 36 18 27 9 9 18]
play [E E B' A' G F# E D E] [9 27 18 36 18 27 9 9 36]
end
to moon
pr [The man in the moon stayed up too late]
play [D B' B' A' A' G D D] [13 45 45 45 45 9 13 13]
play [D G G A' A' B'] [13 9 9 9 9 13]
play [R A' E' E' D' D' C' C' B'] [45 45 45 45 45 45 45 45 9]
play [B' A' A' G G F# A' D'] [9 45 45 45 45 9 9 18]
play [D E G F# A' G] [9 45 45 45 45 9]
end
to ent
pr [Ent and Entwife]
play [A' D' A' A' R A' B' A' G A' R A' C' C' B' A' G A' R] [9 18 9 9 45 9 13 9
9 13 45 9 18 9 9 9 9 13 45]
play [A' D' A' A' R A' B' A' G A' R A' C' C' B' A' G A' R] [9 18 9 9 45 9 13 9
9 13 45 9 18 9 9 9 9 13 45]
play [A' C' C' G R G A#' A#' A' R A' C' C' A' G A' A'] [9 18 9 9 45 9 18 9 6
45 9 13 9 9 9 9 18]
play [A' D' A' A' R A' C' A' A' R A' G F D C D] [9 18 9 9 45 9 13 9 9 45 9 13
9 9 13 18]
end
to donald
pr [Donald McGillavry]
play [E E B B G E R E B B G E] [18 18 45 45 45 18 22 18 45 45 45 36]
play [E E B B G E R D A A F D] [18 18 9 9 9 18 22 18 9 9 18 36]
play [E E B B R E B B G B] [18 18 9 9 18 18 9 9 18 9]
stop ; Not finished...
play [C' B A D' C' B E E B A F D] [9 9 9 9 9 9 9 9 9 9 9 9]
play [B D' E B E R B D' E B G E] [9 9 9 9 9 9 9 9 9 9 9 9]
play [B D' E B E R D D A A F D] [9 9 9 9 9 9 9 9 9 9 9 9]
play [B D' E B R B D' C' B G B] [9 9 9 9 9 9 9 9 9 9 9]
play [C' B A D' C' B E E B A F D] [9 9 9 9 9 9 9 9 9 9 9 9]
end
to elbereth
pr [A Elbereth Gilthoniel]
play [D A B C' E G G F D C D] [9 9 9 9 9 9 9 9 9 9 9]
play [D E F F G F E D C G G F D] [9 9 9 9 9 9 9 9 9 9 9 9 9]
play [D A B C' D' C' B A G E G] [9 9 9 9 9 9 9 9 9 9 9]
play [D E F G A B C' E G G F D C D] [9 9 9 9 9 9 9 9 9 9 9 9 9 9]
end
to fresh.aire
pr [From fresh aire II]
play [G A# A# C' D' C' A# C' A# A A] [9 9 9 9 9 9 9 9 9 9 9]
play [G A# A A# G A G A A] [9 9 9 9 9 9 9 9 9]
play [G A# A# C' D' C' A# C' A# A A] [9 9 9 9 9 9 9 9 9 9 9]
play [G A# A A# G A G F G G] [9 9 9 9 9 9 9 9 9 9]
play [D' G A# C' D' C' A# C' A# A A] [9 9 9 9 9 9 9 9 9 9 9]
play [G A# A A# G A G A A] [9 9 9 9 9 9 9 9 9]
play [D' G A# C' D' C' A# C' A# A A] [9 9 9 9 9 9 9 9 9 9 9]
play [G A# A A# G A G F G G] [9 9 9 9 9 9 9 9 9 9]
end
to while :cond# :body#
label "loopst if run :cond# [run :body#] [stop] go "loopst
end
to music
(local "indx "notes "freqs "A "A# "B "C "C# "D "D# "E "F "F# "G "G# "A' "A#'
"B' "C' "C#' "D' "D#' "E' "F' "F#' "G' "G#' "R)
set.notes
label "loopst
while [keyp] [make "indx rc]
ct pr [Music] pr []
pr [What would you like to hear ?] pr []
pr [1 - Star Wars]
pr [2 - God rest ye merry gentlemen]
pr [3 - Good King Wenceslaus]
pr [4 - Mack the knife]
pr [5 - If I only had a brain]
pr [6 - Day is ended]
pr [7 - The man in the moon stayed up too late]
pr [8 - Ent and Entwife]
pr [9 - Donald McGillavry]
pr [10 - A Elbereth Gilthoniel]
pr [11 - From fresh aire II]
pr []
pr [You can choose 1 to 11] pr []
make "indx rq run item :indx [[stwars] [grest] [gking] [mack] [brain] [day]
[moon] [ent] [donald] [elbereth] [fresh.aire]]
if nodes < 100 [recycle]
go "loopst
end
to play :song :speeds
if emptyp :song [stop] tones list thing (first :song) (first :speeds) play bf
:song bf :speeds
end
to set.notes
make "notes [A A# B C C# D D# E F F# G G# A' A#' B' C' C#' D' D#' E' F' F#' G'
G#' R]
make "freqs [440 466 494 523 554 587 622 659 698 740 784 831 880 934 988 1047
1111 1175 1247 1319 1397 1482 1568 1664 0]
repeat 25 [make (first :notes) (first :freqs) make "notes bf :notes make
"freqs bf :freqs]
end
Words
-----
FRENCH Change the primitives to use French words
to francais
make "redefp "TRUE
make "xlat [and et back recule back re background fondg bury enfouis butfirst
saufpremier bf sp butlast saufdernier bl sd buttonp bouton? bye aurevoir catch
attrape changef renommef char car clean effacedessin clean efd clearscreen
effacegraphique cs efg cleartext effacetexte cleartext eft copyd copiedk copyf
copief copyoff impa copyon impm count compte cursor curseur debug chasse
defaultd disquette define definis definedp defini degrees degres dot point
edall edtout edit edite emptyp vide? equalp egal? erall eftout erase efp erf
detruisfichier ern efn erns efns erps efps error erreur fence limite first
premier first pre fkey deftouche fkey dtc follow ordonne fd avance fd av fput
inserep fput ip fullscreen ecrangraphique getfs lfich glist lprops go va gprop
rprop heading cap ht cachetortue ht ct home centre if si iff sifaux iff sif
ift sivrai ift siv initd initdk int entier int ent keyp touche? label
etiquette last dernier last der lt gauche lt ga list liste listp liste? load
ramene lc minuscules lc minus lpen crayon lpenp crayon? lput insered lput id
make donne memberp membre? name nom namep chose? nodebug finchasse noformat
efcomm noprim efaide not non notrace fintrace nowatch finpasapas numberp
nombre? or ou op retourne package groupe paddle manette pen plume pc
couleurplume pd poseplume pd pp pe effaceur pe er px inverseur px ir penup
leveplume pu lp piece extrait pkgall grptout plist pliste po im poall imtout
pocall imsuiv pons imns popkg imgrps poprim aide pops imps poref imprec potl
imts pprop dprop pps improps primitivep primitive? print affiche pr af
printscreen recopie proclist lproc product produit quote guillemets quote gll
random hasard rc liscar rc lcc rl lisliste rl llc rq lismot rq lmc remainder
reste remprop efprop repeat repete rerandom fixehasard resetd libere rt droite
rt dr round arrondi run execute save sauve se phrase se ph setbg fcfg
setcursor fixecurseur setcursor fcurs setd fixelecteur setd flec seth fixecap
seth fcap setpc fcp setpen fplume setpos fpos setsplit fixem setx fixex sety
fixey show afc shownp visible? st montretortue st mt shuffle melange sizef
taillef spaced restedk splitscreen ecranmixte sqrt rcar sum somme test teste
text texte textbg fcft textfg fcc textscreen ecrantexte thing chose throw
renvoie tones notes towards vers tt legende twoscreen ecrans type afr unbury
deterre uppercase majuscules uppercase maj wait attende watch pasapas where
rang window fenetre word mot wordp mot? wrap enroule]
repeat (count :xlat) / 2 [copydef item 2 :xlat first :xlat make "xlat bf bf
:xlat]
ern "xlat
recycle
end
make "redefp "TRUE
POEM Poem generator
to poem
setbg 1 cs textbg 3 textfg 0 textscreen ct
pr [\ \ \ \ \ Some poetry by the prolific Dr. Logo] pr []
repeat 3 [
(print "\ \ A adj 1 spec 1 aux iverb prep noun 1)
(print "\ \ and aux tverb 0 noun 0 ".)
(print "\ \ But noun 0 tverb 1 noun 0)
(print "\ \ while noun 2 tverb 1 "the adj 2 spec 2 ".)
pr [] pr []]
end
to adj :flag
(local "x)
if :flag = 2 [op :adjective]
make "x first shuffle [gentle happy friendly smart small great]
if :flag = 1 [make "adjective :x]
op :x
end
to spec :flag
(local "x)
if :flag = 2 [op :specifier]
make "x first shuffle [flower tree bird star cloud twig pond dog goat boy
petal wagon wheel gate lark raven girl book]
if :flag = 1 [make "specifier :x]
op :x
end
to aux
op first shuffle [may can shall should must]
end
to iverb
op first shuffle [sing talk run fly aspire think ponder conjure bend whistle]
end
to prep
op first shuffle [on upon over under within beside of in behind below about]
end
to noun :flag
(local "x "q)
if :flag = 2 [op :noun_phrase]
make "q random 8
if :q = 0 [make "x (se "a adj 0 spec 0)] []
if :q = 1 [make "x (se "a spec 0 "of gen 0)] []
if :q = 2 [make "x (se "the prop "of "a spec 0)] []
if :q = 3 [make "x (se "the spec 0 prep noun 0)] []
if :q = 4 [make "x (se gen 0 prep gen 0)] []
if :q = 5 [make "x (se gen 1 prop)] []
if :q = 6 [make "x (se adj 0 gen 0)] []
if :q = 7 [make "x (se "the prop "of gen 0)]
if :flag = 1 [make "noun_phrase :x]
op :x
end
to tverb :flag
(local "x)
make "x first shuffle [flee worship understand find control provoke heal
pursue strengthen become kill arouse becalm ensnare]
if :flag = 1 [make "x (word :x "s)]
op :x
end
to prop
op first shuffle [action duration hunger feeling activity movement motion
endurance tenderness age taste bounty goodness]
end
to gen :flag
(local "x)
make "x first shuffle [time nature age wisdom war peace power energy earth
piety heart land evil fantasy]
if :flag = 1 [make "x (word :x "'s)]
op :x
end
to textbg :n
end
to textfg :n
end
POEM2 Another one
to pronoun
op first shuffle [I We You He She They]
end
to verb.1
op first shuffle [thought knew hoped wished feared anticipated expected
presumed]
end
to verb.2
op first shuffle [saw was had liked lost loved hated found worshipped drank]
end
to verb.3
op first shuffle [sliding dozzing laughing singing sneeking hiding running
jumping]
end
to noun.1
op first shuffle [misfortune mistake whiskey honey woman child calamity]
end
to noun.2
op first shuffle [door. lamppost. fireplace. bar. chair. bed. kitchen. pool.]
end
to noun.3
op first shuffle [[a penny postage stamp.] [a nasty patch of damp.] [an awfly
painful cramp.]]
end
to poem
pr []
(pr pronoun verb.1 lc pronoun verb.2 "a noun.1)
(pr verb.3 [by the] noun.2)
(pr pronoun [looked again and found it was])
(pr noun.3)
pr []
end
To be explained
---------------
PATHS Traveling salesman program, but how to use it?
to make_routes
make "city_list []
label "another_pair
pr [Type a city, a distance, and a city.]
make "route readlist
if :route = [] [stop]
if not (count :route) = 3
[pr [Not enough data, try again.]]
[if not numberp first bf :route
[pr [The distance must be a number.]]
[connect :route
connect reverse :route]]
go "another_pair
end
to get_routes :start
initial
investigate :start 0
show_distances
end
to remove_all
remove_list :city_list
make "city_list []
end
to initial
init_cities :city_list
end
to init_cities :list
if :list = [] [stop]
pprop first :list "distance 32767
init_cities bf :list
end
to investigate :city :dist
pr [Looking at] :city [distance is] :dist
if :dist < gprop :city "distance
[pprop :city "distance :dist
examine_each gprop :city "routes :dist]
end
to examine_each :routes :dist
if :routes = [] [stop]
investigate last first :routes
dist + first first :routes
examine_each bf :routes :dist
end
to connect :cities
if not memberp first :cities :city_list
[make "city_list fput first :cities :city_list]
pprop first :cities "routes
fput butfirst :cities
gprop first :cities "routes
end
to reverse :list
if :list = [] [op []]
op lput first :list reverse butfirst :list
end
to show_distances
show_city :city_list
end
to show_city :list
if emptyp :list [stop]
pr first :list gprop first :list "distance
show_city bf :list
end
to remove_list :cities
if :cities = [] [stop]
remprop first :cities "distance
remprop first :cities "routes
remove_list bf :cities
end
To be modified
--------------
DRAW Drawing using a joystick
to calibrate
ct pr [Position the joystick as far up and left as it will go.]
pr [Press button 1 when ready.] pr []
label "cal1
if not buttonp 0 [go "cal1]
make "xs paddle 0
make "ys paddle 1
pr [Position the joystick as far down and right as it will go.]
pr [Press button 1 when ready.] pr []
label "cal2
if not buttonp 0 [go "cal2]
make "xl paddle 0
make "yl paddle 1
pr [Center the joystick and press button 1] pr []
label "cal3
if not buttonp 0 [go "cal3]
make "xc paddle 0
make "yc paddle 1
(pr :xs :xc :xl :ys :yc :yl)
end
to draw
(local "body "dx "dy "k "n "ox "oy "p "x "xc "xl "xs "y "yc "yl "ys)
cs calibrate
make "ox 0 make "oy 0 setpc 3 make "body [] make "p [pd]
pu setpos (list :ox :oy) st
ss ct
pr [U = up D = down E = erase]
pr [X = reverse F = fill ESC = quit]
pr [1 = pc1 2 = pc2 3 = pc3 4 = pc4]
loop [
if keyp [
make "k rc
if :k = "u [make "p [pu] add [pu]]
if :k = "d [make "p [pd] add [pd]]
if :k = "e [make "p [pe] add [pe]]
if :k = "x [make "p [px] add [px]]
if :k = "f [run :p fill pu add [fill]]
if memberp :k [0 1 2 3] [setpc :k add (se "setpc :k)]
if :k = char 27 [stop]]
make "x (paddle 0) make "y (paddle 1) pu setpos (list :x - :xc :yc - :y)
if and (buttonp 0) (or (:x <> :xs) (:y <> :ys)) [
make "x :x - :xc make "y :yc - :y
run :p setpos (list :ox :oy) pu
add (se "rt round ((towards (list :x :y)) - heading) "fd dist :ox :oy :x
:y)
seth towards (list :x :y) setpos (list :x :y) make "ox :x make "oy :y]
if buttonp 1 [
ct type [Procedure name?\ ] make "n first rl define :n (list [] :body)
make "body [] make "p [pd] make "ox :xc make "oy :yc setpc 3 cs ct
pr [U = up D = down E = erase]
pr [X = reverse F = fill ESC = quit]
pr [1 = pc1 2 = pc2 3 = pc3 4 = pc4]]]
end
to loop :code
label "loop
run :code
go "loop
end
to add :new
make "body (se :body :new)
end
to dist :x1 :y1 :x2 :y2
make "x1 :x1 - :x2 make "y1 :y1 - :y2
op round (sqrt (:x1 * :x1 + :y1 * :y1))
end
to bg
op first sf
end
to pc
op item 5 tf
end
to pen
op piece 4 5 tf
end
to shownp
op last tf
end
to sp :pal
(local "bg)
make "bg remainder (first sf) 16
if :pal > 2 [make "bg :bg + 16 make "pal :pal - 3]
if :pal > 0 [make "bg :bg + 32]
setbg :bg
end
What's that?
------------
ROLEPLAY Draws a page listing the characteristics of each player?
---------------------------------------------------------------------
Name: Race: Dwarven Sex: Female Handedness: Right
ST = 12 DX = 15 IQ = 11 Gold = 51
Weapon: Mace
Armor: Plate
Notes
to roll :n :m
(local "t)
make "t :n
repeat :n [make "t :t + random :m]
op :t
end
to character
setres 1
(local "Race "Strength "Dexterity "Intelligence "Luck)
(local "Sex "Gold "Weapon "Armor "Handedness)
repeat 70 [type [_]] pr []
make "Race first shuffle [Human Elven Dwarven]
make "Sex first shuffle [Male Female]
make "Handedness first shuffle [Right Right Right Right Left Left both]
make "Strength roll 3 6
make "Dexterity roll 3 6
make "Intelligence roll 3 6
make "Luck roll 3 6
make "Gold roll 10 10
make "Weapon first shuffle [Sword Axe Mace Spear Shortbow Cestus]
make "Armor first shuffle [None Leather Chainmail Fishmail Plate]
if :Race = "Human [make "Luck min (:Luck + 2) 18]
if :Race = "Elven [make "Dexterity min (:Dexterity + 2) 18]
if :Race = "Dwarven [make "Strength min (:Strength + 2) 18]
type [Name:] tab 25 (type [Race:] :Race) tab 40 (type [Sex:] :Sex) tab 53
(pr [Handedness:] :Handedness)
(type [ST =] :Strength) tab 9 (type [DX =] :Dexterity) tab 17
(type [IQ =] :Intelligence) tab 25 (type [LK =] :Luck) tab 40
(pr [Gold =] :Gold) (pr [Weapon:] :Weapon) (pr [Armor:] :Armor) pr [notes:]
repeat 10 [pr []]
end
to min :n :m
if :n < :m [op :n] [op :m]
end
to tab :n
make "n :n - (first cursor)
if :n > 0
[repeat :n [type "\ ]]
end
Not working?
------------
DYNA Dynaturtle? (How to use it?)
to command
make "com readkey
if :com = "r [right 30 update]
if :com = "l [left 30 update]
if :com = "k [kick :force update]
if :com = "f [make "force :force + 1 update]
if :com = "s [make "force :force - 1 update]
if :com = "c [cs make "force 1 update]
if :com = "u [pu]
if :com = "d [pd]
if :com = "e [pe]
if :com = "x [px]
if memberp :com [0 1 2 3] [setpc :com]
end
to dt
moveturtle
command
dt
end
to kick :force
make "vx :vx + :force * (sin heading)
make "vy :vy + :force * (cos heading)
end
to moveturtle
setpos se (xcor + :vx) (ycor + :vy)
end
to play
cs ss wrap
make "force 1
make "vx 0
make "vy 0
st update dt
end
to readkey
if keyp [output lc readchar]
output "
end
to update
ct
pr [R\=rt L\=lt F\=force S\=subdue K\=kick C\=cs]
pr [D\=pd E\=pe U\=pu X\=px 0 1 2 3 \=pencolor]
(type [Heading =] heading [Force =] :force [Toward =] towards se (xcor + :vx)
(ycor + :vy))
end
EOF