;;; -*- logo -*-
;;;
;;; .logo -- Logo initialization file (v.0.9.0)   Hrvoje Blazevic
;;;

;; Reversing 5.1 changes
;; Don't like getter/setter syntax "simplification". .LOOPS is
;; slow even without ALLOWGETSET. UNBURYONEDIT is meaningless
;; in logo-mode, and can possibly get in the way.
make "state.allowgetset :allowgetset
make "state.unburyonedit :unburyonedit
bury [[] [state.allowgetset state.unburyonedit] []]
erase [[] [allowgetset unburyonedit] []]
pr [ALLOWGETSET and UNBURYONEDIT disabled]

type "|loading LOOPS ... | wait 0

;; Allowing changes to Logo primitives

make "redefp "true

;; Preserving original definitions

copydef "if.tf "if                                                            
copydef "ifelse.tf "ifelse
copydef "not.tf "not
copydef "and.tf "and
copydef "or.tf "or
copydef "test.tf "test

;; Freeing names

erase [if ifelse not and or test]


;;; New definitions

.macro if :tf.val :run.true [:run.false []] 2
op (if.tf equalp :tf.val "false [:run.false] [:run.true])
end

.macro ifelse :tf.val :run.true :run.false
op (if.tf equalp :tf.val "false [:run.false] [:run.true])
end

to not :thing.not
op (if.tf equalp :thing.not "false ["true] ["false])
end

to true
op "true
end

to false
op "false
end

copydef "else "true
copydef "t "true

to and [:form.and ["true]] [:forms.and] 2
if.tf emptyp :forms.and [op run :form.and]
if run :form.and [op apply "and :forms.and]
op "false
end

to or [:form.or ["false]] [:forms.or] 2
if.tf emptyp :forms.or [op run :form.or]
cond.if run :form.or
op apply "or :forms.or
end

.macro cond.if :#cond.val
if :#cond.val [op list "op :#cond.val]
op []
end

to .and [:form.and ["true]] [:forms.and] 2
if.tf emptyp :forms.and [op first lput "#unspecified runresult :form.and]
if.tf not first lput "#unspecified runresult :form.and [op "false]
op apply ".and :forms.and
end

.macro test :any.value
op (list "test.tf "not.tf "not quoted :any.value)
end

;;; Extended prefix operators

copydef "difference.s "difference
copydef "quotient.s "quotient

erase [difference quotient equal? greater? less? before?]

to difference :first.num [:rest.nums] 2
if.tf emptyp :rest.nums [op minus :first.num]
op :first.num - (apply "sum :rest.nums)
end

to quotient :first.num [:rest.nums] 2
if.tf emptyp :rest.nums [op (1 / :first.num)]
op :first.num / (apply "product :rest.nums)
end

to equal? :elt [:rest] 2
op emptyp find [not.tf equalp ? :elt] :rest
end

to less? :elt [:nums] 2
if.tf emptyp :nums [op "true]
if.tf :elt < first :nums [op apply "less? :nums]
op "false
end

to greater? :elt [:nums] 2
if.tf emptyp :nums [op "true]
if.tf greaterp :elt first :nums [op apply "greater? :nums]
op "false
end

to before? :wd [:wds] 2
if.tf emptyp :wds [op "true]
if.tf beforep :wd first :wds [op apply "before? :wds]
op "false
end

to lesseq? :elt [:nums] 2
if.tf emptyp :nums [op "true]
if.tf :elt > first :nums [op "false]
op apply "lesseq? :nums
end

to greatereq? :elt [:nums] 2
if.tf emptyp :nums [op "true]
if.tf lessp :elt first :nums [op "false]
op apply "greatereq? :nums
end

to beforeq? :wd [:wds] 2
if.tf emptyp :wds [op "true]
if.tf beforep first :wds :wd [op "false]
op apply "beforeq? :wds
end

;;; Cleaning up

;; Prohibit further changes of primitives
ern "redefp

bury [if ifelse not true false else or and .and test cond.if]
bury [difference equal? greater? less? greatereq? lesseq? beforeq? quotient
                 before? difference.s quotient.s]


;;; Defining High Level Structures

;;; Letrec

.macro letrec :in.letrec
local [body.letrec method.&stack]
make "method.&stack []
make "body.letrec fput "dummy.letrec (list fput [] bf :in.letrec)
op insert.invoke letrec.helper lput :body.letrec first :in.letrec
end

to letrec.helper :clauses.letrec
if.tf emptyp :clauses.letrec [op (list "run [(dummy.letrec)])]
push "method.&stack first first :clauses.letrec
op (se "local (word "" first :method.&stack)
       "make (word "" first :method.&stack)
       bf first :clauses.letrec letrec.helper bf :clauses.letrec)
end

to insert.invoke :text 
if.tf emptyp :text [op []]
if.tf wordp first :text [
   op (or [(and [equalp first :text "\(]
                [memberp first bf :text :method.&stack]
                [(se first :text "invoke word ": first bf :text
                     insert.invoke bf bf :text)])]
          [se first :text insert.invoke  bf :text])]
op (if.tf listp first :text [fput insert.invoke runparse first :text
                                  insert.invoke bf :text]
          [fput first :text insert.invoke bf :text])
end

;;; Cond -- 2 versions

;; universal -- operation and command
.macro cond.ifelse :#cond.val :#cond.rest
op ifelse :#cond.val [(list :#cond.val)] [:#cond.rest]
end

.macro cond :cond.clauses
local [fclauses lclause]
make "lclause last :cond.clauses
(if.tf and [wordp first :lclause]
       [memberp first :lclause [else true t]]
       [make "lclause apply "se bf :lclause
             make "fclauses bl :cond.clauses]
       [make "fclauses :cond.clauses make "lclause ["#unspecified]])
op cond.helper :fclauses
end

to cond.helper :cond.clauses
if.tf emptyp :cond.clauses [op :lclause]
if.tf emptyp bf first :cond.clauses [
   op (se "cond.ifelse first first :cond.clauses
          (list cond.helper bf :cond.clauses))]
op (se "ifelse.tf first first :cond.clauses
       (list apply "se bf first :cond.clauses)
       (list cond.helper bf :cond.clauses))
end

;; command only -- slightly faster
.macro condc :cond.clauses
local [fclauses lclause]
make "lclause last :cond.clauses
(if.tf and [wordp first :lclause]
       [memberp first :lclause [else true t]]
       [make "lclause apply "se bf :lclause
             make "fclauses bl :cond.clauses]
       [make "fclauses :cond.clauses make "lclause ["#unspecified]])
op condc.helper :fclauses
end

to condc.helper :cond.clauses
if.tf emptyp :cond.clauses [op :lclause]
if.tf emptyp bf first :cond.clauses [
   op (se "cond.if first first :cond.clauses
          condc.helper bf :cond.clauses)]
op (se "if.tf first first :cond.clauses
       (list apply "se bf first :cond.clauses)
       condc.helper bf :cond.clauses)
end

;;; Case

;; universal -- operation and command, but *must* output a value

.macro case :case.clauses
local [fclauses lclause]
make "lclause last :case.clauses 
(if.tf and [wordp first :lclause]
       [memberp first :lclause [else true t]]
       [make "lclause apply "se bf :lclause
             make "fclauses bl bf :case.clauses]
       [make "fclauses bf :case.clauses make "lclause ["#unspecified]])
op (se (list "local ""#target "make ""#target "run first :case.clauses)
       case.helper :fclauses)
end

to case.helper :first.clauses
if.tf emptyp :first.clauses [op :lclause]
op (se "ifelse.tf "memberp ":#target
       (list first first :first.clauses) 
       (list apply "se bf first :first.clauses)
       (list case.helper bf :first.clauses))
end

;;; casec

;; command only -- mix code, true forms do not have to output
.macro casec :case.clauses
local [fclauses lclause]
make "lclause last :case.clauses 
(if.tf and [wordp first :lclause]
       [memberp first :lclause [else true t]]
       [make "lclause apply "se lput [op "#unspecified] bf :lclause
             make "fclauses bl bf :case.clauses]
       [make "fclauses bf :case.clauses make "lclause [op "#unspecified]])
op (se (list "local ""#target "make ""#target "run first :case.clauses)
       casec.helper :fclauses)
end

to casec.helper :first.clauses
if.tf emptyp :first.clauses [op :lclause]
op (se "ifelse.tf "memberp ":#target
       (list first first :first.clauses) 
       (list apply "se lput [op "#unspecified] bf first :first.clauses)
       (list casec.helper bf :first.clauses))
end


;;; Compiler -- source is commented out. Only the compiled code gets loaded.

; to loops.compiler [:proc procedures] 1
; letrec [[
;    [compile.proc [[proc]
;                   [if emptyp :proc [op []]]
;                   [local "struct.min]
;                   [op ifelse.tf
;                       (and [wordp first :proc]
;                            [macrop first :proc]
;                            [not gprop "compiler.cap first :proc]
;                            [not.tf emptyp bf :proc]
;                            [listp first bf :proc])
;                       [make "compiled "true
;                             se (list "run macroexpand list first :proc
;                                      (compile.proc first bf :proc))
;                             (compile.proc bf bf :proc)]
;                       [or [and [listp first :proc]
;                                [fput (compile.proc first :proc)
;                                      (compile.proc bf :proc)]]
;                           [fput first :proc (compile.proc bf :proc)]]]]]
;    [compile.ws [[proc.lst compiled]
;                 [if.tf emptyp :proc.lst [stop]]
;                 [.type (se "compiling  first :proc.lst "|... |)]
;                 [wait 0]
;                 [(invoke (or [and [macrop first :proc.lst]
;                                   [".defmacro]]
;                              ["define])
;                          first :proc.lst (compile.proc text first :proc.lst))]
;                 [.pr (if.tf :compiled
;                             [.and [pprop "compiled.procs first :proc.lst "true]
;                                   ["OK]]
;                             [(se [nothing to do for] first :proc.lst)])]
;                 [(compile.ws bf :proc.lst "false)]]]]
;         [ifelse listp :proc [(compile.ws filter "procedurep :proc "false)]
;                 [(compile.ws filter "procedurep (list :proc) "false)]]
;         [.pr [compilation completed]]]
; end

;;; Invoking the compiler from logo-mode with Compile Workspace
;;
;; Using ws.compile instead of loops.compiler
;; Filtering out all procedure names that end with .class
;; Compiling Class templates, firstly makes no sense, secondly,
;; will make Class unusable to the OBJECT.MAKER
;;
;;; ws.compile

to ws.compile
local "split
(loops.compiler
               filter
               [[x] [make "split split.word :x ".
                          op not (and [1 < count :split]
                                      [equalp last :split "class])]]
               procedures)
end

to compile.object :text
if.tf emptyp :text [op []]
if.tf (and [wordp first :text]
           [macrop first :text]
           [not gprop "compiler.cap first :text]
           [not.tf emptyp bf :text]
           [listp first bf :text]) ~
           [op se (list "run macroexpand list first :text
                        compile.object first bf :text)
               compile.object bf bf :text]
if.tf listp first :text ~
      [op fput compile.object first :text compile.object bf :text]
op fput first :text compile.object bf :text
end

to .type :text
if.tf :.verbose [type :text]
end

to .pr :text
if.tf :.verbose [pr :text]
end

;; specifying compiler output 
make ".verbose "true

;; Saving *only* compiled procedures. 

to save.compiled [:filename .and
                            [type "|Enter file name to save to: |]
                            [rw]] 1
if.tf namep "printwidthlimit ~
      [localmake "width :printwidthlimit ern "printwidthlimit]
if.tf namep "printdepthlimit ~
      [localmake "depth :printdepthlimit ern "printdepthlimit]
if equalp first :filename "" [make "filename bf :filename]
local "oldwriter
make "oldwriter writer
openwrite :filename
setwrite :filename
po (filter [[proc] [op not.tf emptyp gprop "compiled.procs :proc]]
           procedures)
setwrite :oldwriter
close :filename
if.tf namep "width [make "printwidthlimit :width]
if.tf namep "depth [make "printdepthlimit :depth]
end


;;; Compiler Capabilities
;;;
;;; Capabilities have this format: property = name of High Level Procedure
;;;                                value    = "false
;;;
;;; You can add your own compiler capabilities, providing you follow
;;; these rules: High level procedure (structure) you define must have
;;; one input only - a list. And, of-course it must be a macro --
;;; otherwise there is nothing for compiler to do. After you have
;;; defined (and tested) your procedure add your pprop line to lines
;;; below. That is all.

pprop "compiler.cap "letrec "false
pprop "compiler.cap "cond "false
pprop "compiler.cap "condc "false
pprop "compiler.cap "case "false
pprop "compiler.cap "casec "false

bury [[insert.invoke letrec letrec.helper cond cond.helper loops.compiler
                     compile.object save.compiled case .pr case.helper
                     casec casec.helper .type ws.compile condc condc.helper
                     cond.ifelse]
      [.verbose] [compiler.cap compiled.procs]]

;;; End of interpreter changes (.logo)


;;; Additions to Logo library 

to before :first.wd [:rest.wds] 2
if emptyp :rest.wds [op :first.wd]
if beforep first :rest.wds :first.wd [op apply "before :rest.wds]
op apply "before fput :first.wd bf :rest.wds
end

to max :first [:rest] 2
if emptyp :rest [op :first]
if greaterp :first first :rest [op apply "max fput :first bf :rest]
op apply "max :rest
end

to min :first [:rest] 2
if emptyp :rest [op :first]
if lessp :first first :rest [op apply "min fput :first bf :rest]
op apply "min :rest
end

to evenp :number
op zerop remainder :number 2
end

copydef "even? "evenp

to oddp :number
op not evenp :number
end

copydef "odd? "oddp

to zerop :number
op equalp :number 0
end

copydef "zero? "zerop

to identity :stuff
op :stuff
end

to last.pair :lst
if emptyp bf :lst [op :lst]
op last.pair bf :lst
end

to split.word :string [:delimiter "\ ] 2
local "result
if emptyp :string [op (list ")]
make "result split.word bf :string :delimiter
if equalp first :string :delimiter [op fput " :result]
op fput word first :string first :result bf :result
end

to time :instruction.list
localmake "start first first shell [date "+%s"]
pr runresult :instruction.list
(pr "Elapsed "time: (first first shell [date "+%s"]) - :start "seconds)
end

.macro begin :begin.forms
op apply "se :begin.forms
end

bury [before max min evenp even? oddp odd? zerop zero? identity last.pair
             split.word time begin]

;;; Restoring Standard Berkeley Logo
;;; This is of practical value only if used within Emacs logo-mode

to restore.standard
make "redefp "true
copydef "if "if.tf                                                     
copydef "ifelse "ifelse.tf
copydef "not "not.tf
copydef "and "and.tf
copydef "or "or.tf
copydef "test "test.tf
copydef "difference "difference.s
copydef "quotient "quotient.s
copydef "equal? "equalp
copydef "greater? "greaterp
copydef "less? "lessp
copydef "before? "beforep
;; .logo
make "allowgetset :state.allowgetset
make "unburyonedit :state.unburyonedit
bury [[] [allowgetset unburyonedit] []]
erase [
   [if.tf ifelse.tf not.tf and.tf or.tf test.tf false else t true .and
          insert.invoke letrec letrec.helper cond cond.helper cond.if
          cond.ifelse condc condc.helper loops.compiler ws.compile
          save.compiled case case.helper difference.s quotient.s lesseq?
          greatereq? beforeq? .type .pr casec casec.helper begin]
   [.verbose state.allowgetset state.unburyonedit]
   [compiler.cap compiled.procs]]
;; loops
erase [
   [object.maker static.make compile.object bucket.class base.object
                 counter.class send rewinding.counter.class container.class
                 stack.class delegate #self border.class browse.classes
                 circular.class double.end.class edit.classes indirect
                 inherit inherit.from insert.method insert.tree
                 inspect.methods.objects lambda list.class loops new
                 objects.group pair.class queue.class save.image send.helper
                 show.method.object static swap.pair.class word.class]
   [.accept.method loops.object.stack] [inheritance.tree]]
ern "redefp
gc ignore nodes gc ignore nodes gc
pr [Standard Berkeley Logo restored.]
end

bury [restore.standard loops.compiler]


;;; Compiled code

to loops.compiler [:proc procedures] 1
run [local "compile.proc make "compile.proc [[proc] [if emptyp :proc [op []]] [local "struct.min] [op ifelse.tf ( and [wordp first :proc] [macrop first :proc] [not gprop "compiler.cap first :proc] [not.tf emptyp bf :proc] [listp first bf :proc] ) [make "compiled "true se ( list "run macroexpand list first :proc ( invoke :compile.proc first bf :proc ) ) ( invoke :compile.proc bf bf :proc )] [or [and [listp first :proc] [fput ( invoke :compile.proc first :proc ) ( invoke :compile.proc bf :proc )]] [fput first :proc ( invoke :compile.proc bf :proc )]]]] local "compile.ws make "compile.ws [[proc.lst compiled] [if.tf emptyp :proc.lst [stop]] [.type ( se "compiling first :proc.lst "|... | )] [wait 0] [( invoke ( or [and [macrop first :proc.lst] [".defmacro]] ["define] ) first :proc.lst ( invoke :compile.proc text first :proc.lst ) )] [.pr ( if.tf :compiled [.and [pprop "compiled.procs first :proc.lst "true] ["OK]] [( se [nothing to do for] first :proc.lst )] )] [( invoke :compile.ws bf :proc.lst "false )]] local "dummy.letrec make "dummy.letrec [[] [ifelse listp :proc [( invoke :compile.ws filter "procedurep :proc "false )] [( invoke :compile.ws filter "procedurep ( list :proc ) "false )]] [.pr [compilation completed]]] run [( invoke :dummy.letrec )]]
end

type [Lisp layer OK ...]


;;; End of .logo