Rotate GET/PUT arrays

Area:    Quik_Bas
  Msg:    #289
 Date:    12-11-92 06:33 (Public) 
 From:    Steve Gartrell           
 To:      Geoffrey Liu             
 Subject: Rotate GET/PUT arrays

'For big arrays, this screams for conversion to assembly.
'But, using this, it's just a translation job.
'Remember, this is a pixel by pixel rotation, so at
'angles other than 0 or 180, lettering is reversed.  (You'd
'need to approach it in blocks the size of a standard
'character in whichever screen mode you were in, to do
'writing.  I wasn't going to do it all!!!)
DEFINT A-Z
DECLARE SUB RotateArray (SourceArray%(), TargetArray%(), Angle%)
'Must have the appropriate QB.QLB/QBX.QLB/VBDOS.QLB loaded
' if in the environment-link with appropriate library....
DECLARE SUB ABSOLUTE (Var%, BYVAL HowFar%, address AS INTEGER)
CONST C$ = "Created 12/01/92 by Steve Gartrell"
CONST NumBytes = 21
'$STATIC
DIM SHARED RORproc%(1 TO (NumBytes / 2))
'$DYNAMIC
DIM SHARED BitsPP%, Planes%, MaskBits%
DIM TheScreens%(1 TO 9)
offset% = VARPTR(RORproc%(1))
FOR byte% = 0 TO NumBytes - 1
  READ opcode%
  POKE (offset% + byte%), opcode%
NEXT byte%
TheScreens%(1) = 1
TheScreens%(2) = 2
TheScreens%(3) = 7
TheScreens%(4) = 8
TheScreens%(5) = 9
TheScreens%(6) = 11
TheScreens%(7) = 12
TheScreens%(8) = 13
KEY OFF
ScrCnt% = 8
DO
  SCREEN TheScreens%(ScrCnt%)
  MaskBits% = 128
  SELECT CASE TheScreens%(ScrCnt%)
    CASE 1   'Screen 1
    MaskBits% = 192
    BitsPP% = 2: Planes% = 1
    ColorMod% = 3
    CASE 2   'Screen 2
    BitsPP% = 1: Planes% = 1
    ColorMod% = 2
    CASE 7   'Screen 7
    BitsPP% = 1: Planes% = 4
    ColorMod% = 16
    CASE 8   'Screen 8
    BitsPP% = 1: Planes% = 4
    ColorMod% = 16
    CASE 9  'Screen 9
    BitsPP% = 1: Planes% = 4
    ColorMod% = 16
    CASE 11  'Screen 11
    BitsPP% = 1: Planes% = 1
    ColorMod% = 2
    CASE 12  'Screen 12
    BitsPP% = 1: Planes% = 4
    ColorMod% = 16
    CASE 13  'Screen 13
    MaskBits% = 255
    BitsPP% = 8: Planes% = 1
    ColorMod% = 256
  END SELECT
  StartX% = 119: StartY% = 55: EndX% = 199: EndY% = 135
  ArrayBytes& = 4 + INT(((EndX% - StartX% + 1)_
 * (BitsPP%) + 7) / 8) * Planes% * ((EndY% - StartY%) + 1)
  REDIM SourceArray%(0 TO ArrayBytes& \ 2)
  REDIM BlankArray%(0 TO ArrayBytes& \ 2)
  REDIM TargetArray%(0 TO 20)
  GET (StartX%, StartY%)-(EndX%, EndY%), BlankArray%(0)
  FOR TheLine% = 1 TO 24
    LOCATE TheLine%, 1
    FOR cnt% = 33 TO 72
      SELECT CASE TheScreens%(ScrCnt%)
        CASE 1, 2, 11
        CASE ELSE
          COLOR cnt% MOD ColorMod%
      END SELECT
      PRINT CHR$(cnt%);
    NEXT
    IF TheLine% <> 24 THEN PRINT
  NEXT
  GET (StartX%, StartY%)-(EndX%, EndY%), SourceArray%(0)
  DO
    DO: t$ = UCASE$(INKEY$): LOOP UNTIL LEN(t$)
    SELECT CASE t$
      CASE "Q"  'QUIT!!!!!
        SCREEN 0: WIDTH 80: COLOR 7, 0: END
      CASE "N"  'CHANGE SCREEN MODE!!!
        ScrCnt% = ScrCnt% + 1
        IF ScrCnt% = 9 THEN ScrCnt% = 1
        EXIT DO
      CASE ELSE  'ROTATE!!!!
        Angle% = (Angle% + 90) MOD 360
        RotateArray SourceArray%(), TargetArray%(), Angle%
        WAIT &H3DA, 8, 8
        WAIT &H3DA, 8
        PUT (StartX%, StartY%), BlankArray%(0), PSET
        PUT (StartX%, StartY%), TargetArray%(0), PSET
        ERASE TargetArray%
    END SELECT
  LOOP
LOOP
RotRight:
DATA &H55              : 'push   bp
DATA &H8B,&HEC         : 'mov    bp, sp
DATA &H51              : 'push   cx
DATA &H8B,&H4E,&H06    : 'mov    cx, [bp + 6]
DATA &H8B,&H5E,&H08    : 'mov    bx, [bp + 8]
DATA &H8B,&H07         : 'mov    ax, [bx]
DATA &HD2,&HC8         : 'ror    al, cl
DATA &H89,&H07         : 'mov    [bx], ax
DATA &H59              : 'pop    cx
DATA &H5D              : 'pop    bp
DATA &HCA,&H04,&H00    : 'retf   4
REM $STATIC
DEFSNG A-Z
SUB RotateArray (SourceArray%(), TargetArray%(), Angle%)
DIM SourcePix%(1 TO 4)
DIM SourceBitsPP%, SourceBytesPerRow&, SourceRowOffset&
DIM SourceX%, SourceY%, BytePosCopy&, SourceBytePos&
DIM SourceRightMove%, SourceBitMask%, SourceToTargetDiff%
DIM TargetBitsPP%, TargetBytesPerRow&, TargetRowOffset&
DIM TargetRightMove%, TargetBytePos&, TargetX%, TargetY%
DIM WhichBits%, NumCols%, NumRows%
SELECT CASE BitsPP%
  CASE 1
    WhichBits% = 7
  CASE 2
    WhichBits% = 3
  CASE 8
    WhichBits% = 0
END SELECT
SourceBitsPP% = SourceArray%(0)
NumCols% = SourceBitsPP% \ BitsPP%
NumRows% = SourceArray%(1)
IF Angle% MOD 180 THEN
  'Make it square if it's not!!!
  SELECT CASE NumRows% - NumCols%
    CASE IS < 0
      NumCols% = NumRows%
    CASE IS > 0
      NumRows% = NumCols%
  END SELECT
END IF
TargetBitsPP% = NumCols% * BitsPP%
IF TargetBitsPP% AND 7 THEN
  TargetBytesPerRow& = (TargetBitsPP% \ 8 + 1) * Planes%
ELSE
  TargetBytesPerRow& = (TargetBitsPP% \ 8) * Planes%
END IF
REDIM TargetArray%(0 TO ((TargetBytesPerRow& * NumRows%) \ 2) + 2)
TargetArray%(0) = TargetBitsPP%
TargetArray%(1) = NumRows%
TargetBytesPerPlane% = TargetBytesPerRow& \ Planes%
IF SourceBitsPP% MOD 8 THEN
  SourceBytesPerPlane% = (SourceBitsPP% \ 8 + 1)
ELSE
  SourceBytesPerPlane% = (SourceBitsPP% \ 8)
END IF
SourceBytesPerRow& = SourceBytesPerPlane% * Planes%
SourceRowOffset& = 4
SourceBytePos& = SourceRowOffset&
SourceRightMove% = 0
SourceBitMask% = MaskBits%
FOR SourceY% = 0 TO NumRows% - 1
  FOR SourceX% = 0 TO NumCols% - 1
    SELECT CASE Angle%
      CASE 90
        TargetX% = NumRows% - SourceY% - 1
        TargetY% = NumCols% - SourceX% - 1
      CASE 180
        TargetX% = NumCols% - SourceX% - 1
        TargetY% = NumRows% - SourceY% - 1
      CASE 270
        TargetX% = SourceY%
        TargetY% = SourceX%
      CASE ELSE
        TargetX% = SourceX%
        TargetY% = SourceY%
    END SELECT
    TargetRowOffset& = (TargetY% * TargetBytesPerRow&) + 4
    TargetBytePos& = TargetRowOffset& + ((TargetX% * BitsPP%) \ 8)
    TargetRightMove% = TargetX% AND WhichBits%
    IF BitsPP% = 2 THEN
      TargetRightMove% = TargetRightMove% + TargetRightMove%
    END IF
    SourceToTargetDiff% = (TargetRightMove% - SourceRightMove% + 8) AND 7
    BytePosCopy& = SourceBytePos&
    DEF SEG = VARSEG(SourceArray%(0))
    FOR PlaneNum% = 1 TO Planes%
      SourcePix%(PlaneNum%) = (PEEK(BytePosCopy&) AND SourceBitMask%)
      BytePosCopy& = BytePosCopy& + SourceBytesPerPlane%
    NEXT
    IF SourceToTargetDiff% THEN
      DEF SEG
      RotRight% = VARPTR(RORproc%(1))
-end-