https://github.com/jrincayc/ucblogo-code
Raw File
Tip revision: 62fc2f7d6c41edcf685277a872c68e47a76fb254 authored by Dan Malec on 12 December 2020, 01:50:52 UTC
FEAT-CD: Initial pass at having a CD build.
Tip revision: 62fc2f7
UnitTests-OOP.lg
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                        ;;
;;             BERKELEY LOGO              ;;
;;             OOP TEST SUITE             ;;
;;                                        ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


InstallSuite [OOP Tests] [Tests.OOP.Setup]


;; The list of all OOP unit tests
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

MAKE "Tests.OOP [
  Tests.OOP.Ask
  Tests.OOP.Exist
  Tests.OOP.Make
  Tests.OOP.MakeMany
  Tests.OOP.OneOf
  Tests.OOP.OneOfCheckVar
  Tests.OOP.OverrideExist
  Tests.OOP.Parents
  Tests.OOP.TalkTo
  Tests.OOP.Usual
  Tests.OOP.UsualChain
  
  ;; The following are strictly regression tests

  Tests.OOP.ChildWontChangeParent
  Tests.OOP.MemberFunctionOverride
  Tests.OOP.CaseSensitiveMemberVars
  Tests.OOP.OverriddenMethods
  Tests.OOP.UsualInLogo
  Tests.OOP.OverriddenMethods1
  Tests.OOP.OverriddenMethods2
  Tests.OOP.OverriddenMethods3
  Tests.OOP.OverriddenMethods4
  Tests.OOP.MultipleInheritanceTalker
  Tests.OOP.MultipleInheritanceShouter
  Tests.OOP.MultipleInheritanceWhisperer
  Tests.OOP.MultipleInheritanceCombination1
  Tests.OOP.MultipleInheritanceCombination2
  Tests.OOP.ExistChain1
  Tests.OOP.ExistChain2
  Tests.OOP.DoubleDashed
  Tests.OOP.DashedDouble
 ]


;; Test Suite setup procedure, main entry 
;; point for all tests in this suite
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

to Tests.OOP.Setup
  RunTests :Tests.OOP
end


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                 ;;
;; HELPERS & OBJECTS               ;;
;;                                 ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

to ignore :value
end

make "ABase kindof logo
ask :ABase [to Exist]
  have "avar
  make "avar 1
end

make "ExistChild kindof logo
ask :ExistChild [to Exist]
  make "avar 2
end


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                 ;;
;; ADD INDIVIDUAL UNIT TESTS BELOW ;;
;;                                 ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


to safecheck :obj :var :expected
  make "success 0
  CATCH "Error [ignore (ask thing :obj [thing :var]) make "success 1]
  OUTPUT IFELSE [equal? :success 0] [equal? 0 1] [equal? (ask thing :obj [thing :var]) 1]
end

to Tests.OOP.Ask
  make "bob kindof logo
  make "dummy ask :bob [self]
  OUTPUT EQUAL? 1 1
end

to Tests.OOP.Exist
  make "bob oneof :ABase
  OUTPUT EQUAL? (ASK :bob [:avar]) 1
end

to Tests.OOP.Make
  make "bob kindof logo
  OUTPUT Equal? 1 1
end

to Tests.OOP.MakeMany
  make "loqi kindof logo
  make "geetha kindof logo
  make "chaidan (kindof :loqi :geetha)
  OUTPUT equal? (Count ask :chaidan [parents])  2
end

to Tests.OOP.OneOf
  make "bob oneof :ABase
  OUTPUT Equal? 1 1
end

to Tests.OOP.OneOfCheckVar
  make "bob oneof :ABase
  OUTPUT EQUAL? (ASK :bob [:avar]) 1
end

to Tests.OOP.OverrideExist
  make "bob kindof :ExistChild
  ask :bob [exist]
  ;OUTPUT safecheck "bob "avar 2
  OUTPUT Equal? (ask :bob [:avar]) 2
end

to Tests.OOP.Parents
  make "bob kindof logo
  make "jim kindof :bob
  OUTPUT AND (ask :jim [parents]) = (list :bob) (ask :bob [parents]) = (list Logo)
end


to Tests.OOP.TalkTo
  make "bob kindof logo
  ask :bob [have "hat]
  ask :bob [make "hat "red]
  talkto :bob
  make "result equal? :hat "red
  talkto Logo
  OUTPUT :result
end

;; Syntax to test
;;	Usual.Method (inside an object proc call)
;;	Overriding methods (by redefining exsiting methods)
;;	Exist / overriding Exist
;;	Usual.Exist (inside overriden exist)
;;	Make "OBj OneOf :OtherObj (a combination of KindOf and Exist)
;;	Make "NewObj (OneOf :Obj "prop value) -- initialize with specific values
;;	HaveMake "Name Value (have combined with make)


make "Usual1 something
ask :Usual1 [to foo]
  op "True
end

Make "Usual2 kindof :Usual1
ask :Usual2 [to foo]
  op usual.foo
end  

make "Usual3 kindof :Usual2
ask :Usual3 [to foo]
  op usual.foo
end

to Tests.OOP.Usual
   OUTPUT equalp (ask :Usual2 [foo]) "True
end

to Tests.OOP.UsualChain
   OUTPUT equalp (ask :Usual3 [foo]) "True
end

;; -------------------------------------------------
;; REGRESSION TESTS
;; -------------------------------------------------


;; This regression tests verifies
;; that when you change a child value
;; the parent value remains unchanged

to Tests.OOP.ChildWontChangeParent
  make "bob oneof Logo
  ask :bob [have "hat]
  ask :bob [make "hat "blue]
  make "joe oneof :bob
  ask :joe [make "hat "red]
  OUTPUT (ask :bob [:hat]) = (ask :joe [:hat])
end


to Tests.OOP.CaseSensitiveMemberVars
  make "bob something
  ask :bob [have "aVarIable]
  ask :bob [make "aVarIable 1]
  ask :bob [make "avariable 2]
  OUTPUT equal? (ask :bob [:avariable]) 2
end


  to bar
    output "True
  end

  make "a something
  ask :a [to bar]
    output usual.bar
  end
  ask :a [to foo :x]
    output :x
    end
  make "b kindof :a
  ask :b [to foo]
    OUTPUT usual.foo "True
    end

to Tests.OOP.OverriddenMethods
  make "c kindof :b
  (ask :c [make "baz foo])
  OUTPUT equal? (ask :c [:baz]) "True
end

to Tests.OOP.UsualInLogo
  make "c kindof :a
  OUTPUT equal? (ask :c [bar]) "True
end

;; This is setup for the next test
;; Methods are defined a different levels
;; Check that the proper method will get called

make "InheritA something
ask :InheritA [to foo]
  op "fooA
end

make "InheritB kindof :InheritA
ask :InheritB [to bar]
  op "barB
end

make "InheritC kindof :InheritB
ask :InheritC [to foo]
  op "fooC
end

ask :InheritC [to bar]
  op "barC
end

ask :InheritC [to baz1]
  op se foo bar
end

ask :InheritC [to baz2]
  op se foo usual.bar
end

ask :InheritC [to baz3]
  op se usual.foo bar
end

ask :InheritC [to baz4]
  op se usual.foo usual.bar
end

to Tests.OOP.OverriddenMethods1
  OUTPUT equal? (ask :InheritC [baz1]) [fooC barC]
end

to Tests.OOP.OverriddenMethods2
  OUTPUT equal? (ask :InheritC [baz2]) [fooC barB]
end

to Tests.OOP.OverriddenMethods3
  OUTPUT equal? (ask :InheritC [baz3]) [fooA barC]
end

to Tests.OOP.OverriddenMethods4
  OUTPUT equal? (ask :InheritC [baz4]) [fooA barB]
end


;;; G.Drescher: "Object-oriented Logo"
;;; in Lawler, Yazdani: "Artifical Intelligence and Education: Learning environments and tutoring systems", Intellect Books, 1987

make "talker something
ask :talker [have "name]
ask :talker [make "name "gertrude]

ask :talker [to say :msg]
  op (sentence :name "says :msg)
end

ask :talker [to exist]
  make "exist.chain fput "talker :exist.chain
end

;;
make "shouter kindof :talker
ask :shouter [to say :msg]
  op (se "hey! usual.say :msg)
end

ask :shouter [to exist]
  usual.exist
  make "exist.chain fput "shouter :exist.chain
end

;;
make "whisperer kindof :talker
ask :whisperer [to say :msg]
  op (se "shhh...  usual.say :msg)
end

ask :whisperer [to exist]
  usual.exist
  make "exist.chain fput "whisperer :exist.chain
end


;;
make "combination1 (kindof :shouter :whisperer)
ask :combination1 [to exist]
  usual.exist
  make "exist.chain fput "combination1 :exist.chain
end

;;
make "combination2 (kindof :whisperer :shouter)
ask :combination2 [to exist]
  usual.exist
  make "exist.chain fput "combination2 :exist.chain
end

to Tests.OOP.MultipleInheritanceTalker
  OUTPUT equal? (ask :talker [say "hi]) [gertrude says hi]
end

to Tests.OOP.MultipleInheritanceShouter
  OUTPUT equal? (ask :shouter [say "hello]) [hey! gertrude says hello]
end

to Tests.OOP.MultipleInheritanceWhisperer
  OUTPUT equal? (ask :whisperer [say "howdy]) [shhh... gertrude says howdy]
end

to Tests.OOP.MultipleInheritanceCombination1
  OUTPUT equal? (ask :combination1 [say "howdy]) [hey! shhh... gertrude says howdy]
end

to Tests.OOP.MultipleInheritanceCombination2
  OUTPUT equal? (ask :combination2 [say "hola]) [shhh... hey! gertrude says hola]
end

to Tests.OOP.ExistChain1
  make "exist.chain []
  ask :combination1 [exist]
  OUTPUT (equal? :exist.chain
                 [combination1 shouter whisperer talker])
end

to Tests.OOP.ExistChain2
  make "exist.chain []
  ask :combination2 [exist]
  OUTPUT (equal? :exist.chain
                 [combination2 whisperer shouter talker])
end

;; B.Harvey: canonical Object Logo example
;; 4feb2020
;;

make "turtle something

talkto :turtle

to exist
  usual.exist
  have (list "pos "pen "dash.count "dash.len)
  make "pos 0
  make "pen "down
  make "dash.count 0
  make "dash.len 0
end

to setpos :x
  make "pos :x
end

to penup
  make "pen "up
  make "dash.count :dash.count + 1
end

to pendown
  make "pen "down
end

to forward :dist
  if :pen = "down [make "dash.len :dash.len + :dist]
  setpos :pos + :dist
end

make "double.turtle kindof :turtle
talkto :double.turtle
to forward :dist
usual.forward 2*:dist
end

talkto logo
make "dashed.turtle kindof :turtle
talkto :dashed.turtle
to forward :dist
if :dist < 10 [usual.forward :dist stop]
penup
usual.forward 5
pendown
usual.forward 5
forward :dist-10
end

talkto logo

to Tests.OOP.DoubleDashed
  ; 20 length-5 dashes
  local "turtle1
  make "turtle1 oneof (list :double.turtle :dashed.turtle)
  ask :turtle1 [pendown forward 100]
  OUTPUT (equal? ask :turtle1 [(se :pos :pen :dash.count :dash.len)]
                 [200 down 20 100])
end

to Tests.OOP.DashedDouble
  ; 10 length-10 dashes
  local "turtle2
  make "turtle2 oneof (list :dashed.turtle :double.turtle)
  ask :turtle2 [pendown forward 100]
  OUTPUT (equal? ask :turtle2 [(se :pos :pen :dash.count :dash.len)]
                 [200 down 10 100])
end

;; This is setup for the next test
;; When an object has a function with the
;; same name as its parent's, the child's method
;; should be called, not the parent's method

make "MemRegr KindOf Logo
to OOP.Regr.foo
  OUTPUT 1
end

ask :MemRegr [to OOP.Regr.foo]
  OUTPUT 0
end

to Tests.OOP.MemberFunctionOverride
  OUTPUT equal? (ASK :MemRegr [OOP.Regr.foo]) 0
end


;; TODO: Need to test the TO proc on objects
;;       but logo doesn't like it when you use
;;       TO inside a TO

back to top