'===========================================================================
' Subject: MOVING LIGHTS STAIRS DOWN         Date: 03-17-99 (13:15)       
' Author:  Jacob Wieles                      Code: QB, QBasic, PDS, PB    
' Origin:  jacwls@worldonline.nl           Packet: GRAPHICS.ABC
'===========================================================================
'program        : MOTION-3.BAS  (16-03-99)
'                 Playing with a mix of Penrose & Penrose and
'                 Oscar Reutersv„rd stairs and simulation of
'                 moving lights stairs down with data change
'                 in the DAC (Digital Analog Converter)
'which basic    : PowerBASIC and Q(uick)BASIC
'auteur         : Jacob Wieles

defint a-z
ix=2
iy=2
x1=ix:x2=2*ix:x3=3*ix:x4=4*ix:x6=6*ix:x7=7*ix:x8=8*ix:x9=9*ix
x10=10*ix:x11=11*ix:x12=12*ix:x13=13*ix:x16=16*ix
y1=iy:y2=2*iy:y3=3*iy:y4=4*iy:y6=6*iy:y8=8*iy
y12=12*iy:y13=13*iy:y16=16*iy
gosub InitShapes
screen 12
gosub initialcolor
gosub stairs
color 1
locate 1,1
print" Hit a key for go down."
keyhit$=input$(1)
gosub simulation
gosub MakeColorsLight
while inkey$<>"":wend
locate 1,1
print" Hit a key for end.                      "
hitakey$=input$(1)
cls
screen 0
print" Thank you for running this program. Hit a key for the source."
end
'=======================================================================

Stairs:
px=520
py=140
for i=0 to 34
  select case i
  case 0
    pxp=px
    pyp=py
    pset(pxp,pyp)
    draw s01$
    paint(pxp,pyp-2),2+i mod 5,1      'top
    paint(pxp-2,pyp),7,1              'left
    paint(pxp+2,pyp),8,1              'right
  case 1 to 10
    pxp=pxp-x6
    pyp=pyp+y12
    pset(pxp,pyp),1
    if i<10 then
      draw s08$
      paint(pxp,pyp-2),2+i mod 5,1
      paint(pxp-2,pyp),7,1
      paint(pxp+2,pyp),8,1
    else
      draw s08b$
      paint(pxp,pyp-y1),2+i mod 5,1
      paint(pxp+x1,pyp),8,1
    end if
  case 11
    pxp=pxp-x12:pyp=pyp+y8
    pset(pxp,pyp),1
    draw s01$
    paint(pxp,pyp-2),2+i mod 5,1
    paint(pxp-2,pyp),7,1
    paint(pxp+2,pyp),8,1
  case 12 to 19
    pxp=pxp-x16:pyp=pyp-y8
    pset(pxp,pyp),1
    draw s06$
    paint(pxp,pyp-2),2+i mod 5,1
    paint(pxp-2,pyp),7,1
  case 20
    pxp=pxp+x12:pyp=pyp-y8
    pset(pxp,pyp),1
    draw s07v$
    paint(pxp,pyp-2),2+i mod 5,1
    paint(pxp+2,pyp),8,1
  case 21 to 24
    pxp=pxp+x12:pyp=pyp-y8
    pset(pxp,pyp),1
    draw s07$
    paint(pxp,pyp-2),2+i mod 5,1
    paint(pxp+2,pyp),8,1
  case 25 to 32
    pxp=pxp+x12:pyp=pyp-y4
    pset(pxp,pyp),1
    draw s03$
    paint(pxp+2,pyp-y4),2+i mod 5,1
    paint(pxp-2,pyp+y6),7,1
    paint(pxp+2,pyp),8,1
  case 33
    pxp=pxp+x12:pyp=pyp-y8
    pset(pxp,pyp),1
    draw s03e$
    paint(pxp,pyp-y1),2+i mod 5,1
  case 34
    pxp=pxp+x16:pyp=pyp+y8
    pset(pxp,pyp),1
    draw s06$
    paint(pxp,pyp-2),2+i mod 5,1
    paint(pxp-2,pyp),7,1
  end select
next i
return

initialcolor:
  call NewPaletteUsing        '===>>>  PB  set AC (0-15) to (0-15)
  call SetColor(0,0,0,1)      'Color 1: Black
  call SetColor(63,63,63,0)   'Background color White
  call SetColor(50,0,0,7)     'DAC (7) color Red
  call SetColor(0,0,50,8)     'DAC (8) color Blue
  call SetColor(0,50,0,9)     'DAC (9) color Green
  call SetColor(63,0,0,10)    'DAC (10) color Light red
  call SetColor(0,0,63,11)    'DAC (11) color Light blue
  call SetColor(0,63,0,12)    'DAC (12) color Light green
  for i=2 to 6                '5 x paint-color for top >> green
    call ChangeColor(9,i)     'DAC data 2-6
  next i
return

MakeColorslight:
  for i=2 to 6
    call ChangeColor(12,i)
  next i
  call ChangeColor(10,7)
  call ChangeColor(11,8)
return

simulation:
dt!=.2   ' try an other value
do
  locate 1,1
  print" Hit spacebar for stop.";
  print"            "
  do
    for i=0 to 4
      call ChangeColor(12,2+i)           '  Make the colors light
      call ChangeColor(9,6-(5-i) mod 5)  '  Make the colors dark
      t!=timer
      while timer<t!+dt!:wend
    next i
  loop until inkey$=chr$(32)
  locate 1,1
  print" Go on with Enter.";
  print"  Stop with Esc."
  do
    hitakey=asc(input$(1))
  loop until hitakey=27 or hitakey=13
loop while hitakey=13
return

sub ChangeColor(col1,col2)    'R, G and B value from Dac (col1)
  out &H3C7,col1              'to DAC (col2)
  R=inp(&H3C9)
  G=inp(&H3C9)
  B=inp(&H3C9)
  out &H3C8,col2
  out &H3C9,R
  out &H3C9,G
  out &H3C9,B
end sub

sub SetColor(R,G,B,Dac)       'New R, G and B value to DAC (Dac)
  out &H3C8,Dac
  out &H3C9,R
  out &H3C9,G
  out &H3C9,B
end sub

sub NewPaletteUsing
  restore acdata
  dummy=inp(&H3DA)
  for attr=0 to 15
    out &H3C0,attr
    read col
    out &H3C0,col
  next attr
  out &H3C0,32
end sub

InitShapes:
'==============================================================
s01$="c1m+="+varptr$(x12)+",-="+varptr$(y8)
s01$=s01$+"nm-="+varptr$(x16)+",-="+varptr$(y8)+"d="+varptr$(y8)
s01$=s01$+"m-="+varptr$(x12)+",+="+varptr$(y8)
s01$=s01$+"m-="+varptr$(x16)+",-="+varptr$(y8)+"u="+varptr$(y8)
s01$=s01$+"nm+="+varptr$(x12)+",-="+varptr$(y8)
s01$=s01$+"m+="+varptr$(x16)+",+="+varptr$(y8)+"nd="+varptr$(y8)
'================================================================
s02$="c1bm-="+varptr$(x4)+",-="+varptr$(y16)
s02$=s02$+"m+="+varptr$(x13)+",+="+varptr$(y6)
s02$=s02$+"m-="+varptr$(x9)+",+="+varptr$(y6)+"d="+varptr$(y8)
s02$=s02$+"nd="+varptr$(y4)
s02$=s02$+"m+="+varptr$(x3)+",+="+varptr$(y2)
s02$=s02$+"m-="+varptr$(x3)+",+="+varptr$(y2)
s02$=s02$+"m-="+varptr$(x16)+",-="+varptr$(y8)+"u="+varptr$(y8)
s02$=s02$+"m+="+varptr$(x12)+",-="+varptr$(y8)
s02$=s02$+"bm+="+varptr$(x4)+",+="+varptr$(y16)
s02$=s02$+"nm-="+varptr$(x16)+",-="+varptr$(y8)
'==============================================================
s03$="c1bm-="+varptr$(x4)+",-="+varptr$(y16)
s03$=s03$+"m+="+varptr$(x16)+",+="+varptr$(y8)+"d="+varptr$(y8)
s03$=s03$+"m-="+varptr$(x12)+",+="+varptr$(y8)+"nu="+varptr$(y4)
s03$=s03$+"m-="+varptr$(x3)+",-="+varptr$(y2)
s03$=s03$+"m+="+varptr$(x3)+",-="+varptr$(y2)+"u="+varptr$(y8)
s03$=s03$+"bm-="+varptr$(x13)+",-="+varptr$(y6)
s03$=s03$+"m+="+varptr$(x9)+",-="+varptr$(y6)
s03$=s03$+"bm+="+varptr$(x4)+",+="+varptr$(y16)
s03$=s03$+"nm+="+varptr$(x12)+",-="+varptr$(y8)
'==============================================================
s03b$="c1bm-="+varptr$(x4)+",-="+varptr$(y16)
s03b$=s03b$+"m+="+varptr$(x16)+",+="+varptr$(y8)+"d="+varptr$(y4)
s03b$=s03b$+"m-="+varptr$(x12)+",+="+varptr$(y8)
s03b$=s03b$+"m-="+varptr$(x3)+",+="+varptr$(y2)
s03b$=s03b$+"m+="+varptr$(x3)+",+="+varptr$(y2)+"u="+varptr$(y12)
s03b$=s03b$+"bm-="+varptr$(x13)+",-="+varptr$(y6)
s03b$=s03b$+"m+="+varptr$(x9)+",-="+varptr$(y6)
s03b$=s03b$+"bm+="+varptr$(x4)+",+="+varptr$(y16)
s03b$=s03b$+"nm+="+varptr$(x12)+",-="+varptr$(y8)
'==============================================================
s03e$="c1m+="+varptr$(x12)+",-="+varptr$(y8)
s03e$=s03e$+"m-="+varptr$(x16)+",-="+varptr$(y8)
s03e$=s03e$+"m-="+varptr$(x12)+",+="+varptr$(y8)
s03e$=s03e$+"m+="+varptr$(x16)+",+="+varptr$(y8)
'==============================================================

s04$="c1bm-="+varptr$(x4)+",-="+varptr$(y16)
s04$=s04$+"m+="+varptr$(x16)+",+="+varptr$(y8)+"d="+varptr$(y4)
s04$=s04$+"m-="+varptr$(x12)+",+="+varptr$(y8)+"d="+varptr$(y4)
s04$=s04$+"m-="+varptr$(x16)+",-="+varptr$(y8)+"u="+varptr$(y8)
s04$=s04$+"m+="+varptr$(x12)+",-="+varptr$(y8)
s04$=s04$+"bm+="+varptr$(x4)+",+="+varptr$(y16)
s04$=s04$+"nm+="+varptr$(x12)+",-="+varptr$(y8)
s04$=s04$+"nm-="+varptr$(x16)+",-="+varptr$(y8)+"nd="+varptr$(y4)
'==============================================================

s05$="c1bm-="+varptr$(x4)+",-="+varptr$(y16)
s05$=s05$+"m+="+varptr$(x16)+",+="+varptr$(y8)+"d="+varptr$(y8)
s05$=s05$+"m-="+varptr$(x12)+",+="+varptr$(y8)+"u="+varptr$(y4)
s05$=s05$+"m-="+varptr$(x16)+",-="+varptr$(y8)+"u="+varptr$(y4)
s05$=s05$+"m+="+varptr$(x12)+",-="+varptr$(y8)
s05$=s05$+"bm+="+varptr$(x4)+",+="+varptr$(y16)
s05$=s05$+"nm+="+varptr$(x12)+",-="+varptr$(y8)
s05$=s05$+"nm-="+varptr$(x16)+",-="+varptr$(y8)+"nd="+varptr$(y4)
'==============================================================
s06$="c1bm-="+varptr$(x4)+",-="+varptr$(y16)
s06$=s06$+"m+="+varptr$(x16)+",+="+varptr$(y8)
s06$=s06$+"m-="+varptr$(x12)+",+="+varptr$(y8)+"d="+varptr$(y8)
s06$=s06$+"m-="+varptr$(x16)+",-="+varptr$(y8)+"u="+varptr$(y8)
s06$=s06$+"m+="+varptr$(x12)+",-="+varptr$(y8)
s06$=s06$+"bm+="+varptr$(x4)+",+="+varptr$(y16)
s06$=s06$+"m-="+varptr$(x16)+",-="+varptr$(y8)
'==============================================================
s06h$="c1bm+="+varptr$(x4)+",-="+varptr$(y12)
s06h$=s06h$+"m+="+varptr$(x8)+",+="+varptr$(y4)
s06h$=s06h$+"m-="+varptr$(x12)+",+="+varptr$(y8)+"d="+varptr$(y8)
s06h$=s06h$+"m-="+varptr$(x8)+",-="+varptr$(y4)+"u="+varptr$(y8)
s06h$=s06h$+"m+="+varptr$(x12)+",-="+varptr$(y8)
s06h$=s06h$+"bm-="+varptr$(x4)+",+="+varptr$(y12)
s06h$=s06h$+"nm-="+varptr$(x8)+",-="+varptr$(y4)
'==============================================================
s07$="c1bm-="+varptr$(x4)+",-="+varptr$(y16)
s07$=s07$+"m+="+varptr$(x16)+",+="+varptr$(y8)+"d="+varptr$(y8)
s07$=s07$+"m-="+varptr$(x12)+",+="+varptr$(y8)+"u="+varptr$(y8)
s07$=s07$+"m-="+varptr$(x16)+",-="+varptr$(y8)
s07$=s07$+"m+="+varptr$(x12)+",-="+varptr$(y8)
s07$=s07$+"bm+="+varptr$(x4)+",+="+varptr$(y16)
s07$=s07$+"nm+="+varptr$(x12)+",-="+varptr$(y8)
'================================================
s07v$="c1bm-="+varptr$(x4)+",-="+varptr$(y16)
s07v$=s07v$+"m+="+varptr$(x16)+",+="+varptr$(y8)+"d="+varptr$(y8)
s07v$=s07v$+"m-="+varptr$(x6)+",+="+varptr$(y4)
s07v$=s07v$+"bm-="+varptr$(x6)+",-="+varptr$(y4)
s07v$=s07v$+"m-="+varptr$(x16)+",-="+varptr$(y8)
s07v$=s07v$+"m+="+varptr$(x12)+",-="+varptr$(y8)
s07v$=s07v$+"bm+="+varptr$(x4)+",+="+varptr$(y16)
s07v$=s07v$+"nm+="+varptr$(x12)+",-="+varptr$(y8)
'==============================================================
s08$="c1bm+="+varptr$(x12)+",-="+varptr$(y8)
s08$=s08$+"d="+varptr$(y8)
s08$=s08$+"m-="+varptr$(x12)+",+="+varptr$(y8)
s08$=s08$+"m-="+varptr$(x16)+",-="+varptr$(y8)+"u="+varptr$(y8)
s08$=s08$+"m+="+varptr$(x6)+",-="+varptr$(y4)
s08$=s08$+"bm+="+varptr$(x10)+",+="+varptr$(y12)
s08$=s08$+"nm+="+varptr$(x6)+",-="+varptr$(y4)
s08$=s08$+"nm-="+varptr$(x16)+",-="+varptr$(y8)+"nd="+varptr$(y8)
'==============================================================
s08b$="c1m+="+varptr$(x12)+",-="+varptr$(y8)
s08b$=s08b$+"d="+varptr$(y8)
s08b$=s08b$+"m-="+varptr$(x12)+",+="+varptr$(y8)
s08b$=s08b$+"u="+varptr$(y8)
s08b$=s08b$+"m-="+varptr$(x16)+",-="+varptr$(y8)
s08b$=s08b$+"nm+="+varptr$(x6)+",-="+varptr$(y4)
s08b$=s08b$+"bm+="+varptr$(x16)+",+="+varptr$(y8)
'=================================================================
s09$="c1m+="+varptr$(x12)+",-="+varptr$(y8)
s09$=s09$+"nm-="+varptr$(x6)+",-="+varptr$(y3)+"d="+varptr$(y8)
s09$=s09$+"m-="+varptr$(x12)+",+="+varptr$(y8)
s09$=s09$+"m-="+varptr$(x16)+",-="+varptr$(y8)
s09$=s09$+"nu="+varptr$(y1)+"br="+varptr$(x16)
s09$=s09$+"nd="+varptr$(y8)
'==============================================================
s10$="c1d="+varptr$(y8)
s10$=s10$+"nm+="+varptr$(x7)+",-="+varptr$(y4)
s10$=s10$+"m-="+varptr$(x16)+",-="+varptr$(y8)+"u="+varptr$(y8)
s10$=s10$+"m+="+varptr$(x12)+",-="+varptr$(y8)
s10$=s10$+"nm+="+varptr$(x1)+",+="+varptr$(y1)
s10$=s10$+"bm-="+varptr$(x12)+",+="+varptr$(y8)
s10$=s10$+"m+="+varptr$(x16)+",+="+varptr$(y8)+"nd="+varptr$(y8)
'================================================================
s11$="c1m+="+varptr$(x12)+",-="+varptr$(y8)
s11$=s11$+"nm-="+varptr$(x8)+",-="+varptr$(y4)+"d="+varptr$(y8)
s11$=s11$+"m-="+varptr$(x12)+",+="+varptr$(y8)
s11$=s11$+"m-="+varptr$(x16)+",-="+varptr$(y8)
s11$=s11$+"u="+varptr$(y8)
s11$=s11$+"m+="+varptr$(x16)+",+="+varptr$(y8)
s11$=s11$+"nd="+varptr$(y8)
'==============================================================
return

acdata:
data 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15