;  Utilities

pr [ ]
pr [ This file adds menus to the LOGO user interface, ]
pr [ and defines some useful procedures and constants. ]
pr [ ]

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

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

; *** Has this file already been loaded?
if buriedp "utility-stuff [ unbury :utility-stuff ] [ ]

; *** Numerical constants.
make "e  2.71828182845904523536
make "pi 3.14159265358979323846

; *** Output list of all variable names.
make "all [ procedure [ ] output se namelist burylist ] 

; *** Output list of names that contain 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 ] 

; *** Output list of names that contain 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 ] 

; *** Print out contents of directory.
make "dr [
   procedure [ [ ] [ :d :p ] ]
   vpr ( sdir :d :p ) ]

; *** Print out contents of directory, and all sub directories.
make "dra [
   procedure [ [ ] [ :d :p ] ]
   vpr ( sdira :d :p ) ]

; *** Edit the contents of specified variables.
;     This procedure works by calling the "QED" text editor by Darren M.
;     Greenwald. 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 ] 

; *** Close all files, windows, and screens, return 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 ]

; *** Output list of all items in one list that are not in the other.
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 ]

; *** Does nothing. Ignores the output of an operation.
make "ignore [ procedure [ [ :i1 ] :i2 ] ]

; *** Set up the command window menus and demons.
make "initmenu [
   procedure [ ]
   whenmenu [ domenu getmenu ]
   setmenu @0 :com-menu ]

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

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 "LOAD\ CANCELED ]
         [  pr :scr-menu
            load :scr-menu
            pr "LOAD\ COMPLETE ]
         type "? ]
      [ = 2 :scr-menu ]
      [  pr [ ]
         type "SAVING\ FILE:\ \ 
         make "scr-menu ( filerequest "Save\ File\ \ -\  )
         if emptyp :scr-menu
         [  pr "SAVE\ CANCELED ]
         [  pr :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 "SAVE\ COMPLETE ]
         type "? ]
      [ = 3 :scr-menu ]  [ interrupt ]
      [ = 4 :scr-menu ]  [ toplevel ]
      [ = 5 :scr-menu ]  [ end ]
      [ = 6 :scr-menu ]  [ restart ]
      [ = 7 :scr-menu ]  [ quit ] ] ]

; *** 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 ] ]

; *** 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 ]

; *** convert all upper case letters to lower case.
make "lower [
   procedure [ [ :w ] [ ] [ :l :c :o ] ]
   if listp :w
   [  make "o [ ]
      while [ not emptyp :w ]
      [  make "o fput lower first :w :o
         make "w bf :w ]
      output reverse :o ]
   [  make "o " 
      make "c count :w
      while [ >0 :c ]
      [  make "l item :c :w
         if  and  >= ascii :l 65  <= ascii :l 90
         [  make "o fput char + ascii :l 32 :o ]
         [  make "o fput :l :o ]
         make "c - :c 1 ]
      output :o ] ]

; *** Output true if word fits pattern.
make "matchp [
   procedure [ [ :p :w ] [ ] [ :i :cp :cw :fpat :rpat ] ]
   if listp :p
   [  make "i false
      while [ not emptyp :p ]
      [  make "fpat first :p
         if = "~ first :fpat
         [  if matchp bf :fpat :w
            [  output false ]
            [ ] ]
         [  make "i or :i matchp :fpat :w ]
         make "p bf :p ]
      output :i ]
   [ ]
   if = "~ first :p [ output not matchp bf :p :w ] [ ]
   if memberp "* :p
   [  if = first :p "*
      [  while [ = first :p "* ]
         [  make "p bf :p
            if emptyp :p
            [  output true ]
            [ ] ]
         if memberp "* :p
         [  make "cp 1
            while [ not = "* item + 1 :cp :p ] [ make "cp + 1 :cp ]
            make "fpat items 1 :cp :p
            make "rpat restof :cp :p
            make "cw count :w
            make "i 0
            while [ >= :cw  + :i :cp ]
            [  if = :fpat items + 1 :i :cp :w
               [  output matchp :rpat restof ( + :i :cp ) :w ]
               [ ]
               make "i + 1 :i ]
            output false ]
         [  make "cp count :p
            make "i count :w
            output   if >= :i :cp
                     [  =  :p  items ( - :i :cp -1 ) :cp :w ]
                     [ false ] ] ]
      [  make "i 1
         while [ not = "* item + 1 :i :p ] [ make "i + 1 :i ]
         output   if =  items 1 :i :p  items 1 :i :w
                  [  matchp restof :i :p restof :i :w ]
                  [  false ] ] ]
   [ output = :p :w ] ]

; *** Output list of unburied names that do not contain 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 ] 

; *** Output list of all words in the list that fit the pattern.
make "patfilter [
   procedure [ [ :p :f ] [ ] [ :o ] ]
   make "p lower :p
   while [ not emptyp :f ]
   [  if matchp :p lower first :f
      [  make "o fput first :f :o ]
      [ ]
      make "f bf :f ]
   output reverse :o ]

; *** Output list of unburied names that contain 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 ] 

; *** Save names, their bindings, and their protection 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
      saveicon :scr-fn ] ]

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 ] 

; *** Closes windows, screens, and files, erases all but utility-stuff.
make "restart [
   procedure [ ]
   setmenu @0 [ ]
   whenclose [ ]
   whenmenu [ ]
   whenmouse [ ]
   whenchar [ ]
   if buriedp "utility-stuff
   [  erase filter :utility-stuff all
      initmenu
      end ]
   [  erase namelist
      erase burylist
      recycle
      toplevel ] ]

; *** 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 ) ] ]

; *** Output sorted directory list.
make "sdir [
   procedure [ [ ] [ :d :p ] [ :c :t :dn :fn ] ]
   if emptyp :d [ make "c dir ] [ make "c ( dir :d ) ]
   if emptyp :p [ ] [ make "c patfilter :p :c ]
   while [ not emptyp :c ] [
      make "t first :c
      make "c bf :c
      if = "/ last :t
         [ make "dn fput :t :dn ] 
         [ make "fn fput :t :fn ] ]
   output
      se if > count :dn 1 [ sort "alphap :dn ] [ :dn ]
         if > count :fn 1 [ sort "alphap :fn ] [ :fn ] ]

; *** Output sorted directory list.
make "sdira [
   procedure [ [ ] [ :d :p ] [ :c :t :dn :fn :w ] ]
   if emptyp :d
      [ make "c dir make "d "  ]
      [  make "c ( dir :d )
         if or = "/ last :d = ": last :d
            [  ]
            [  make "d word :d "/ ] ]
   if emptyp :p [ ] [ make "c patfilter :p :c ]
   while [ not emptyp :c ] [
      make "t first :c
      make "c bf :c
      if = "/ last :t
         [ make "dn fput :t :dn ] 
         [ make "fn fput :t :fn ] ]
   make "dn if > count :dn 1 [ sort [ not alphap ] :dn ] [ :dn ]
   while [ not emptyp :dn ] [
      make "t first :dn
      make "dn bf :dn
      make "c fput ( sdira word :d :t ) :c
      make "c fput :t :c ] 
   output se :c if > count :fn 1 [ sort "alphap :fn ] [ :fn ] ]

; *** Sort list according to test. Where "test" is the compare operation.
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 ] ]

; *** Prepare screen, window, and turtle for simple turtle graphics.
make "turtle [
   procedure [ [ ] [ :v :d ] ]
   if numberp :d [ ] [ make "d 1 ]
   if numberp :v [ ] [ make "v 3 ]
   ( intuition 6 @0 )
   recycle
   make "s1 ( openscreen :v :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 ) ]

; *** Print out contents of lists verticaly.
make "vpr [
   procedure [ [ :l ] [ :i ] ]
   if emptyp :i [ make "i 0 ] [ ]
   if listp :l
   [  while [ not emptyp :l ]
      [  ( vpr first :l + 1 :i )
         make "l bf :l ]
      pr [ ] ]
   [  repeat :i [ type "\  ] 
      pr :l ] ]

; *** A list of names defined in this file.
make "utility-stuff [  e pi dr dra sdir sdira edit prosave allnames names
   allprocs procs justburied all link linksub ignore
   patfilter lower matchp
   end reverse filter initmenu domenu do-com-menu interrupt restart
   sort vpr com-menu turtle utility-stuff ] 

; *** Bury the names defined in this file.
bury :utility-stuff

; *** Initialize the command window menus and menu demon.
initmenu