;  This file contains some usefull procedures and constants.

; *********************************************************************
;  Set amount of memory reserved by LOGO.
( system 2 122880 )

;  Scramble random number generater.
( seedrand * 100 seconds )

;  Has this file allready been loaded?
if buriedp "startup-stuff [ unbury :startup-stuff ] [ ]

; *********************************************************************
;  Numerical constants.

make "e  2.71828182845904523536
make "pi 3.14159265358979323846

; *********************************************************************
;  all
;     Output list of all names.

make "all [ procedure [ ] output se namelist burylist ] 

; *********************************************************************
;  allnames
;     Output list of names bound to something other than procedures.

make "allnames [ 
   procedure [ [ ] [ ] [ :scr-n :scr-x :scr-o ] ] 
   make "scr-n se burylist namelist 
   dowhile 
   [  make "scr-x first :scr-n 
      make "scr-n bf :scr-n 
      if (  or primitivep :scr-x 
            procedurep :scr-x 
            if > 4 count :scr-x 
            [  false ] 
            [  = "scr- items 1 4 :scr-x ] ) 
      [ ] 
      [  make "scr-o fput :scr-x :scr-o ] ] 
   [ not emptyp :scr-n ] 
   output :scr-o ] 

; *********************************************************************
;  allprocs
;     Output list of names bound to procedures.

make "allprocs [ 
   procedure [ [ ] [ ] [ :scr-n :scr-x :scr-o ] ] 
   make "scr-n se burylist namelist 
   dowhile 
   [  make "scr-x first :scr-n 
      make "scr-n bf :scr-n 
      if procedurep :scr-x 
      [  make "scr-o fput :scr-x :scr-o ] 
      [ ] ] 
   [ not emptyp :scr-n ] 
   output :scr-o ] 

; *********************************************************************
;  edit           name
;                 name-list
;     Edit the contents of named variables. You may replace "qed" with the
;     name of the text editor of your choice.

make "edit [ 
   procedure [ [ :scr-n ] ] 
   prosave "ram:LOGO-workspace :scr-n 
   doscommand [ qed ram:LOGO-workspace ] 
   load "ram:LOGO-workspace ] 

; *********************************************************************
;  end
;     Closes all files, windows, and screens, returns to toplevel.

make "end [
   procedure [ ]
   while [ not emptyp filelist ] [ close first filelist ]
   while [ not emptyp screenlist ] [ closescreen first screenlist ]
   while [ not emptyp windowlist ] [ closewindow first windowlist ]
   while [ not emptyp system 6 ] [ ( system 5 first system 6 ) ]
   recycle
   toplevel ]

; *********************************************************************
;  filter         list list
;     Output list of all items in the second list except the items that are
;     in the first list.

make "filter [
   procedure [ [ :r :f ] [ ] [ :o ] ]
   while [ not emptyp :f ]
   [  if memberp first :f :r
      [ ]
      [  make "o fput first :f :o ]
         make "f bf :f ]
   output reverse :o ]

; *********************************************************************
;  ignore         object (...)
;     Does nothing. Ignores the output of an operation.

make "ignore [ procedure [ [ :i1 ] :i2 ] ]

; *********************************************************************
;  initmenu
;     Set up the command window menus and demons.

make "com-menu [  \ \ \ LOGO\ \ \ \ \ 
                  [ \ Load L ]
                  [ \ Save    [ \ Names N ]
                              [ \ Procs P ]
                              [ \ All A ] ]
                  [ \ Interrupt I ]
                  [ \ Top\ Level T ]
                  [ \ End E ]
                  [ \ Restart R ]
                  [ \ Quit Q ] ]

make "initmenu [
   procedure [ ]
   whenmenu [ domenu getmenu ]
   setmenu @0 :com-menu ]

make "domenu [
   procedure [ [ :scr-menu ] [ ] [ :scr-sub ] ]
   if = @0 first :scr-menu
   [  if = 1 item 2 :scr-menu
      [ do-com-menu :scr-menu ]
      [  if and   procedurep "more-menus
                  not = 0 item 2 :scr-menu
         [  more-menus :scr-menu ]
         [ ] ] ]
   [  if procedurep "window-menus
      [  window-menus :scr-menu ]
      [ ] ] ]

make "do-com-menu [
   procedure [ [ :scr-menu ] [ ] [ :scr-sub ] ]
   make "scr-sub item 4 :scr-menu
   make "scr-menu item 3 :scr-menu
   cond
   [  [ = 1 :scr-menu ]
      [  pr [ ]
         type "LOADING\ FILE
         make "scr-menu ( filerequest "Load\ File\ \ -\  )
         if emptyp :scr-menu
         [  pr "CANCELED ]
         [  type :scr-menu
            load :scr-menu
            pr "LOADED ]
         type "? ]
      [ = 2 :scr-menu ]
      [  pr [ ]
         type "SAVING\ FILE
         make "scr-menu ( filerequest "Save\ File\ \ -\  )
         if emptyp :scr-menu
         [  pr "CANCELED ]
         [  type :scr-menu
            cond
            [  [ = 1 :scr-sub ]  [ prosave :scr-menu names ]
               [ = 2 :scr-sub ]  [ prosave :scr-menu procs ]
               [ = 3 :scr-sub ]  [ prosave :scr-menu all ] ]
            pr "SAVED ]
         type "? ]
      [ = 3 :scr-menu ]  [ interrupt ]
      [ = 4 :scr-menu ]  [ toplevel ]
      [ = 5 :scr-menu ]  [ end ]
      [ = 6 :scr-menu ]  [ restart ]
      [ = 7 :scr-menu ]  [ quit ] ] ]

; *********************************************************************
;  interupt
;     A LOGO command shell that may be run from within other procedures.

make "interrupt [
   procedure [ [ ] [ ] [ :scr-list ] ]
   pr "INTERRUPT
   while [ not memberp "cont :scr-list ]
   [  catch "error [
      while [ type "-->  make "scr-list rl  not memberp "cont :scr-list ]
      [  run :scr-list ]
      stop ]
   poerror ] ]

; *********************************************************************
;  link           name
;     Output list of all procedures needed to run the named procedure.

make "link [
   procedure [ [ :proc-name ] [ ] [ :link-list ] ]
   if procedurep :proc-name
   [  make "link-list se :proc-name [ ]
      linksub bf bf thing :proc-name ]
   [  ( pr :proc-name [ is not a procedure ] ) output [ ] ]
   output :link-list ]

make "linksub [
   procedure [ [ :proc-list ] [ ] [ :lfirst ] ]
   if emptyp :proc-list [ stop ] [ ]
   make "lfirst first :proc-list
   cond
   [  [  listp :lfirst ]   [ linksub :lfirst ]
      [  procedurep :lfirst ]
      [  if memberp :lfirst :link-list
         [ ]
         [  make "link-list fput :lfirst :link-list
            linksub bf bf thing :lfirst ] ] ]
   linksub bf :proc-list stop ]

; *********************************************************************
;  names
;     Output list of unburied names bound to something other than
;     procedures.

make "names [ 
   procedure [ [ ] [ ] [ :scr-n :scr-x :scr-o ] ] 
   make "scr-n namelist 
   dowhile 
   [  make "scr-x first :scr-n 
      make "scr-n bf :scr-n 
      if (  or primitivep :scr-x 
            procedurep :scr-x 
            if > 4 count :scr-x 
            [  false ] 
            [  = "scr- items 1 4 :scr-x ] ) 
      [ ] 
      [  make "scr-o fput :scr-x :scr-o ] ] 
   [ not emptyp :scr-n ] 
   output :scr-o ] 

; *********************************************************************
;  procs
;     Output list of unburied names bound to procedures.

make "procs [ 
   procedure [ [ ] [ ] [ :scr-n :scr-x :scr-o ] ] 
   make "scr-n namelist 
   dowhile 
   [  make "scr-x first :scr-n 
      make "scr-n bf :scr-n 
      if procedurep :scr-x 
      [  make "scr-o fput :scr-x :scr-o ] 
      [ ] ] 
   [ not emptyp :scr-n ] 
   output :scr-o ] 

; *********************************************************************
;  prosave        file-name name
;                 file-name name-list
;     Save names, their bindings, and their protection (bury) status to
;     file.

make "prosave [ 
   procedure [ [ :scr-fn :scr-n ] [ ] [ :scr-b :scr-fp ] ] 
   if listp :scr-n 
   [  make "scr-b justburied :scr-n ] 
   [  if buriedp :scr-n 
      [  make "scr-b se :scr-n [ ] ] 
      [  make "scr-b [ ] ] ] 
   if emptyp :scr-b 
   [  save :scr-fn :scr-n ] 
   [  make "scr-fp open :scr-fn 
      catch "error 
      [  fprint :scr-fp [ ] 
         fprint :scr-fp [ ] 
         ( fshow :scr-fp "unbury :scr-b ) 
         fprint :scr-fp [ ] 
         fprintout :scr-fp :scr-n 
         fprint :scr-fp [ ] 
         ( fshow :scr-fp "bury :scr-b ) 
         fprint :scr-fp [ ] ] 
      close :scr-fp ] ] 

make "justburied [ 
   procedure [ [ :scr-n ] [ ] [ :scr-x :scr-o ] ] 
   dowhile 
   [  make "scr-x first :scr-n 
      make "scr-n bf :scr-n 
      if buriedp :scr-x 
      [  make "scr-o fput :scr-x :scr-o ] 
      [ ] ] 
   [ not emptyp :scr-n ] 
   output :scr-o ] 

; *********************************************************************
;  restart
;     Closes windows, screens, and files, erases all but startup-stuff.
;     Restores LOGO to startup condition.

make "restart [
   procedure [ ]
   setmenu @0 [ ]
   whenclose [ ]
   whenmenu [ ]
   whenmouse [ ]
   whenchar [ ]
   if buriedp "startup-stuff
   [  erase filter :startup-stuff all
      initmenu
      end ]
   [  erase namelist
      erase burylist
      recycle
      toplevel ] ]

; *********************************************************************
;  reverse        object ( object )
;     Reverse the order of the items in the object.

make "reverse [ 
   procedure [ [ :from ] [ :into ] ]
   if emptyp :into
   [  if wordp :from
      [  make "into "  ] [ ] ] [ ]
   if emptyp :from
   [  output :into ]
   [  output  ( reverse  bf :from  fput first :from :into ) ] ]

; *********************************************************************
;  sort           test list
;     Sort list according to test. Where "test" is the compare operation.
;  sort "alphap all
;  sort [ not alphap ] all

make "sort [
   procedure [ [ :comparep :ra ] [ ] [ :n :l :j :ir :i :rra ] ]
   make "comparep ( se  [ procedure [ [ :a :b ] ] output ]
                        :comparep
                        [ :a :b ] )
   make "n count :ra
   make "ra se :ra [ ]
   make "l + 1 int / :n 2
   make "ir :n
   while [ true ]
   [  if > :l 1
      [  make "l - :l 1
         make "rra item :l :ra ]
      [  make "rra item :ir :ra
         repitem :ir :ra item 1 :ra
         make "ir - :ir 1
         if = :ir 1 
         [  output fput :rra bf :ra ] [ ] ]
      make "i :l
      make "j * 2 :l
      while [ >= :ir :j ]
      [  if if    < :j :ir
            [ comparep item :j :ra item + 1 :j :ra ]
            [ false ]
         [  make "j + 1 :j ] [ ]
         if comparep :rra item :j :ra
         [  repitem :i :ra item :j :ra
            make "i :j
            make "j + :i :j ]
         [  make "j + 1 :ir ] ]
      repitem :i :ra :rra ] ]

; *********************************************************************
;  turtle         ( bit-planes )
;     Prepare screen, window, and turtle for simple turtle graphics.

make "turtle [
   procedure [ [ ] [ :d ] ]
   if numberp :d [ ] [ make "d 1 ]
   ( intuition 6 @0 )
   recycle
   make "s1 ( openscreen 3 :d [ turtle ] )
   make "w1 openwindow :s1
   make "t1 openturtle :w1
   setrgb :s1 0 [ 0  0  0 ]
   setrgb :s1 1 [ 14 14 14 ]
   ( intuition 2 @0 0 0 )
   ( intuition 8 @0 550 54 )
   if < 300 peek -2 psum peek 0 :s1 14
   [  ( intuition 1 @0 0 350 ) ]
   [  ( intuition 1 @0 0 150 ) ]
   ( intuition 6 @0 ) ]

; *********************************************************************
;  vpr            object
;     Print out contents of lists verticaly.

make "vpr [
   procedure [ [ :l ] [ :i ] ]
   if emptyp :i [ make "i 0 ] [ ]
   repeat :i [ type "\  ]
   if listp :l
   [  pr "[
      while [ not emptyp :l ]
      [  ( vpr first :l + 1 :i )
         make "l bf :l ]
      repeat :i [ type "\  ]
      pr "] ]
   [ pr :l ] ]

; *********************************************************************
;  Names defined in this file.

make "startup-stuff [  e pi edit prosave allnames names
   allprocs procs justburied all link linksub ignore
   end reverse filter initmenu domenu do-com-menu interrupt restart
   sort ppr com-menu turtle startup-stuff ] 

bury :startup-stuff

; *********************************************************************
;  Set up the command window menus and demons.

initmenu