关闭

当年我QB的封笔之作——在VGA 12h 模式下实时抖动绘制真彩色数据

标签: integerfunctionstringcwindows算法
2852人阅读 评论(3) 收藏 举报
分类:

当年我QB的封笔之作——在VGA 12h 模式下实时抖动绘制真彩色数据

'View RGB
'作者:zyl910

'使用有序抖动算法(dither)绘制线性渐变区域、RGB色彩空间(Screen 12下)
' Up , Down , PageUp , PageDown: 改变B分量
' F4~F8: 改变背景
' Esc: 退出
'直接在QB环境下运行速度很慢,编译为exe后就快些了

'展示了以下技术:
'1.QB在 VGA 12h 如何快速绘图
'2.有序抖动算法的实现
'3.模拟Windows窗口,特别是像Windows 98那样的渐变标题栏

 

ViewRGB的界面

代码
'View RGB
'作者:zyl910
'使用有序抖动算法(dither)绘制线性渐变区域、RGB色彩空间(Screen 12下)
' Up , Down , PageUp , PageDown: 改变B分量
' F4~F8: 改变背景
' Esc: 退出
'直接在QB环境下运行速度很慢,编译为exe后就快些了
'展示了以下技术:
'1.QB在 VGA 12h 如何快速绘图
'2.有序抖动算法的实现
'3.模拟Windows窗口,特别是像Windows 98那样的渐变标题栏
 

'== Rect =====================================================================
TYPE Rect
 Left AS INTEGER
 Top AS INTEGER
 Right AS INTEGER
 Bottom AS INTEGER
END TYPE
CONST RectNoNum = &H8000
DECLARE FUNCTION GetRectW% (rct AS Rect)
DECLARE FUNCTION GetRectH% (rct AS Rect)
DECLARE SUB SetRect (rct AS Rect, x1%, y1%, x2%, y2%)
DECLARE SUB SetRectPos (rct AS Rect, x%, y%)
DECLARE SUB SetRectSize (rct AS Rect, w%, h%)
DECLARE SUB MoveRect (rct AS Rect, x%, y%)
DECLARE SUB SizeRect (rct AS Rect, x%, y%)
DECLARE SUB SetRectMinMax (rct AS Rect, MinX%, MinY%, MaxX%, MaxY%)
DECLARE SUB RectAddSize (rct AS Rect, xAdd AS INTEGER, yAdd AS INTEGER)
DECLARE FUNCTION RectIsNull% (rct AS Rect)
'== Bit ======================================================================
DECLARE SUB InitBit ()
DECLARE FUNCTION MakeWord% (LoByte AS INTEGER, HiByte AS INTEGER)
CONST True = -1
CONST False = 0
'== MemCopy ==================================================================
DECLARE SUB InitMemCopy ()
DECLARE SUB MemCopy (fromseg%, fromoffset%, toseg%, tooffset%, bytes%)
'== Font =====================================================================
DECLARE SUB InitFont ()
DECLARE SUB DrawText (rct AS Rect, DrawStr AS STRING)
DECLARE SUB DrawTextEx (rct AS Rect, StepX AS INTEGER, StepY AS INTEGER, DrawStr AS STRING, c AS INTEGER)
CONST CharWi = 8
CONST CharHe = 16
'== Color ====================================================================
DECLARE SUB InitLightM ()
DECLARE FUNCTION RGB12% (x%, y%, R%, G%, B%)
'== Draw =====================================================================
DECLARE SUB DrawEdge (qrc AS Rect, Edge AS INTEGER)
DECLARE SUB DrawEdge0 (qrc AS Rect, Edge AS INTEGER)
CONST BdrRAISEDOUTER = &H1 '外层凸
CONST BdrSUNKENOUTER = &H2 '外层凹
CONST BdrRAISEDINNER = &H4 '内层凸
CONST BdrSUNKENINNER = &H8 '内层凹
CONST BdrRAISED = &H5 '凸
CONST BdrSUNKEN = &HA '凹
CONST BdrOuter = &H3 '外
CONST BdrInner = &HC '内
CONST EdgeRAISED = (BdrRAISEDOUTER OR BdrRAISEDINNER)
CONST EdgeETCHED = (BdrSUNKENOUTER OR BdrRAISEDINNER)
CONST EdgeBUMP = (BdrRAISEDOUTER OR BdrSUNKENINNER)
CONST EdgeSUNKEN = (BdrSUNKENOUTER OR BdrSUNKENINNER)

DECLARE SUB FillRect (rct AS Rect, c AS INTEGER)
CONST OnlyLine = &H8000

DECLARE SUB GradH12 (rct AS Rect, cl%, cr%)
DECLARE SUB GradV12 (rct AS Rect, ct%, cb%)

DECLARE SUB DrawForm (rct AS Rect, TitleStr AS STRING)
DECLARE SUB DrawCaption (rct AS Rect, TitleStr AS STRING)
'== Shared Var ===============================================================
DIM SHARED BitMaskInt(0 TO &HF) AS INTEGER
DIM SHARED ASM.MemCopy AS STRING * 28
DIM SHARED FontData(0 TO &HF, 0 TO &HFF) AS INTEGER
DIM SHARED TextC AS INTEGER
DIM SHARED TextStepX AS INTEGER
DIM SHARED TextStepY AS INTEGER
DIM SHARED TextLf AS INTEGER
DIM SHARED AutoLf AS INTEGER
DIM SHARED CharAdd AS INTEGER
DIM SHARED LineAdd AS INTEGER
DIM SHARED BaseLightnessMatrix(0 TO 15, 0 TO 15) AS INTEGER
DIM SHARED LightnessMatrix(0 TO 15, 0 TO 15) AS INTEGER
DIM SHARED RGBIndex(0 TO 1, 0 TO 1, o TO 1) AS INTEGER
'== Const ====================================================================
CONST MyTitle = "View RGB (For QB) V1.0"

CONST ScrColor = 3
CONST ScrWi = 640
CONST ScrHe = 480
CONST MaxWi = ScrWi - 1
CONST MaxHe = ScrHe - 1
CONST TitleHe = 18
CONST TitleLC = 1
CONST TitleRC = 9
CONST CapHe = 1 + TitleHe + 1
CONST EdgeSize = 2
CONST FormBkC = 7
CONST FormTitleC = &HF
CONST FormTop = EdgeSize + CapHe
CONST FormLeft = EdgeSize + 1
CONST FormRight = EdgeSize + 1
CONST FormBottom = EdgeSize + 1
CONST FormStep = 4
CONST MapWi = &H100
CONST MapHe = &H100
CONST MaxMapWi = MapWi - 1
CONST MaxMapHe = MapHe - 1
CONST SolWi = &H10
CONST CurW = 8
CONST CurH = 5
'== Var ======================================================================
DIM I AS INTEGER, J AS INTEGER, K AS INTEGER
DIM ScrRect AS Rect
DIM FormRect AS Rect
DIM MyMap(0 TO ((MapWi / 8) * 4 / 2) * MapHe + 1) AS INTEGER
DIM valueB AS INTEGER
DIM Idx0 AS INTEGER, Idx AS INTEGER, CurIdx AS INTEGER
DIM TempInt(0 TO 3) AS INTEGER
DIM c AS INTEGER
DIM rct AS Rect
DIM HSB(0 TO 6) AS INTEGER
DIM ik AS STRING
DIM KeyCode AS INTEGER
DIM CurMap(0 TO ((CurW + 7) / 8) * 4 * CurH / 2 + 1) AS INTEGER
'== Begin ====================================================================
SCREEN 12
InitMemCopy
InitBit
InitFont
InitLightM
GOSUB LoadCur
HSB(0) = &HC
HSB(1) = &HE
HSB(2) = &HA
HSB(3) = &HB
HSB(4) = &H9
HSB(5) = &HD
HSB(6) = &HC

SetRect ScrRect, 0, 0, ScrWi, ScrHe
FillRect ScrRect, ScrColor
'GradV12 ScrRect, 10, 2

WHILE INKEY$ <> "": WEND 'Clean Key

GOSUB MakeMap
FormRect.Left = 0
FormRect.Top = 0
FormRect.Right = FormLeft + FormStep + MapWi + FormStep + SolWi + CurW + FormStep + FormRight
FormRect.Bottom = FormTop + FormStep + MapHe + FormStep + FormBottom
SetRectPos FormRect, (ScrWi - FormRect.Right) / 2, (ScrHe - FormRect.Bottom) / 2
GOSUB DrawMe
'WHILE INKEY$ = "": WEND
DO
 ik = INKEY$
 IF ik <> "" THEN
  IF LEN(ik) > 1 THEN
   KeyCode = ASC(MID$(ik, 2, 1))
   SELECT CASE KeyCode
   CASE 72'Up
    IF valueB > 0 THEN
     GOSUB DrawCur
     valueB = valueB - 1
     GOSUB DrawCur
     GOSUB MakeMap
     GOSUB DrawMap
    END IF
   CASE 80'Down
    IF valueB < &HFF THEN
     GOSUB DrawCur
     valueB = valueB + 1
     GOSUB DrawCur
     GOSUB MakeMap
     GOSUB DrawMap
    END IF
   CASE 73 'PageUp
    IF valueB > 0 THEN
     GOSUB DrawCur
     valueB = valueB - &H10
     IF valueB < 0 THEN valueB = 0
     GOSUB DrawCur
     GOSUB MakeMap
     GOSUB DrawMap
    END IF
   CASE 81 'PageDown
    IF valueB < &HFF THEN
     GOSUB DrawCur
     valueB = valueB + &H10
     IF valueB > &HFF THEN valueB = &HFF
     GOSUB DrawCur
     GOSUB MakeMap
     GOSUB DrawMap
    END IF
   CASE 62 'F4
    FillRect ScrRect, ScrColor
    GOSUB DrawMe
   CASE 63 'F5
    GradH12 ScrRect, 10, 2
    GOSUB DrawMe
   CASE 64 'F6
    GradV12 ScrRect, 10, 2
    GOSUB DrawMe
   CASE 65 'F7
    rct.Top = 0
    rct.Bottom = ScrHe
    FOR I = 1 TO 6
     rct.Left = (I - 1) * ScrWi / 6
     rct.Right = I * ScrWi / 6
     GradH12 rct, HSB(I - 1), HSB(I)
    NEXT I
    GOSUB DrawMe
   CASE 66 'F8
    rct.Left = 0
    rct.Right = ScrWi
    FOR I = 1 TO 6
     rct.Top = (I - 1) * ScrHe / 6
     rct.Bottom = I * ScrHe / 6
     GradV12 rct, HSB(I - 1), HSB(I)
    NEXT I
    GOSUB DrawMe
   END SELECT
  ELSE
   KeyCode = ASC(ik)
   SELECT CASE KeyCode
   CASE 27 'Esc
    EXIT DO
   END SELECT
  END IF
 END IF
LOOP
SCREEN 0
END
LoadCur:
LINE (0, 0)-(CurW - 1, CurH - 1), 0, BF
LINE (CurW / 2, 0)-(0, CurH / 2), &HF
LINE -(CurW / 2, CurH - 1), &HF
LINE -(CurW - 1, CurH - 1), &HF
LINE -(CurW - 1, 0), &HF
LINE -(CurW / 2, 0), &HF
PAINT (CurW / 2, CurH / 2), &HF
GET (0, 0)-(CurW - 1, CurH - 1), CurMap
'WHILE INKEY$ = "": WEND
RETURN

DrawCur:
PUT (FormRect.Left + FormLeft + FormStep + MapWi + FormStep + SolWi, FormRect.Top + FormTop + FormStep + valueB - CurH / 2), CurMap, XOR
RETURN

MakeMap:
MyMap(0) = MapWi
MyMap(1) = MapHe
Idx0 = 2
FOR I = 0 TO MaxMapHe
 FOR J = 0 TO MaxMapWi
  CurIdx = J AND &HF
  IF CurIdx = 0 THEN
   FOR K = 0 TO 3
    TempInt(K) = 0
   NEXT K
  END IF
  c = RGB12(I, J, I, J, valueB)
  FOR K = 0 TO 3
   IF BitMaskInt(7 - K) AND c THEN TempInt(K) = TempInt(K) OR BitMaskInt(CurIdx)
  NEXT K
  IF CurIdx = &HF THEN
   Idx = Idx0
   FOR K = 0 TO 3
    MyMap(Idx) = TempInt(K)
    Idx = Idx + &H10 'MapWi/8/2
   NEXT K
   Idx0 = Idx0 + 1
  END IF
 NEXT J
 Idx0 = Idx0 + &H30 '(MapWi/8/2)*3
NEXT I
RETURN

DrawMap:
PUT (FormRect.Left + FormLeft + FormStep, FormRect.Top + FormTop + FormStep), MyMap, PSET
RETURN
DrawMe:
DrawForm FormRect, MyTitle
SetRect rct, 0, 0, SolWi, MapHe
MoveRect rct, FormLeft + FormStep + MapWi + FormStep, FormTop + FormStep
MoveRect rct, FormRect.Left, FormRect.Top
GradV12 rct, 0, 9
GOSUB DrawMap
GOSUB DrawCur
RETURN
'有序抖动亮度趋势矩阵
DATA 00,EB,3B,DB,0F,E7,37,D7,02,E8,38,D9,0C,E5,34,D5
DATA 80,40,BB,7B,8F,4F,B7,77,82,42,B8,78,8C,4C,B4,74
DATA 21,C0,10,FB,2F,CF,1F,F7,22,C2,12,F8,2C,CC,1C,F4
DATA A1,61,90,50,AF,6F,9F,5F,A2,62,92,52,AC,6C,9C,5C
DATA 08,E1,30,D0,05,EF,3F,DF,0A,E2,32,D2,06,EC,3C,DC
DATA 88,48,B0,70,85,45,BF,7F,8A,4A,B2,72,86,46,BC,7C
DATA 29,C8,18,F0,24,C5,14,FF,2A,CA,1A,F2,26,C6,16,FC
DATA A9,69,98,58,A4,64,94,54,AA,6A,9A,5A,A6,66,96,56
DATA 03,E9,39,D8,0D,E4,35,D4,01,EA,3A,DA,0E,E6,36,D6
DATA 83,43,B9,79,8D,4D,B5,75,81,41,BA,7A,8E,4E,B6,76
DATA 23,C3,13,F9,2D,CD,1D,F5,20,C1,11,FA,2E,CE,1E,F6
DATA A3,63,93,53,AD,6D,9D,5D,A0,60,91,51,AE,6E,9E,5E
DATA 0B,E3,33,D3,07,ED,3D,DD,09,E0,31,D1,04,EE,3E,DE
DATA 8B,4B,B3,73,87,47,BD,7D,89,49,B1,71,84,44,BE,7E
DATA 2B,CB,1B,F3,27,C7,17,FD,28,C9,19,F1,25,C4,15,FE
DATA AB,6B,9B,5B,A7,67,97,57,A8,68,99,59,A5,65,95,55
SUB DrawCaption (rct AS Rect, TitleStr AS STRING)
 DIM TempRect AS Rect
 TempRect.Left = rct.Left + EdgeSize
 TempRect.Top = rct.Top + EdgeSize
 TempRect.Right = rct.Right - EdgeSize
 SetRectSize TempRect, RectNoNum, CapHe
 FillRect TempRect, FormBkC OR OnlyLine
 SizeRect TempRect, -1, -1
 GradH12 TempRect, TitleLC, TitleRC
 DrawTextEx TempRect, 3, 1, TitleStr, FormTitleC
END SUB
SUB DrawEdge (qrc AS Rect, Edge AS INTEGER)
 DIM Inner AS INTEGER, Outer AS INTEGER
 DIM TempRect AS Rect
 Inner = Edge AND BdrInner
 Outer = Edge AND BdrOuter
 TempRect = qrc
 IF Outer = 0 THEN
 ELSEIF Outer = BdrOuter THEN
 ELSE
  DrawEdge0 TempRect, Outer
  SizeRect TempRect, -1, -1
 END IF
 IF Inner = 0 THEN
 ELSEIF Inner = BdrInner THEN
 ELSE
  DrawEdge0 TempRect, Inner
 END IF
END SUB
SUB DrawEdge0 (qrc AS Rect, Edge AS INTEGER)
 CONST c0 = &H0
 CONST c1 = &H8
 CONST c2 = &H7
 CONST c3 = &HF
 DIM clt AS INTEGER, crb AS INTEGER
 IF qrc.Right <= qrc.Left THEN EXIT SUB
 IF qrc.Bottom <= qrc.Top THEN EXIT SUB
 SELECT CASE Edge
 CASE BdrRAISEDOUTER
  clt = c2
  crb = c0
 CASE BdrSUNKENOUTER
  clt = c1
  crb = c3
 CASE BdrRAISEDINNER
  clt = c3
  crb = c1
 CASE BdrSUNKENINNER
  clt = c0
  crb = c2
 END SELECT
 LINE (qrc.Left, qrc.Top)-(qrc.Right - 1, qrc.Top), clt
 LINE (qrc.Left, qrc.Top)-(qrc.Left, qrc.Bottom - 1), clt
 LINE (qrc.Right - 1, qrc.Top)-(qrc.Right - 1, qrc.Bottom - 1), crb
 LINE (qrc.Left, qrc.Bottom - 1)-(qrc.Right - 1, qrc.Bottom - 1), crb
END SUB
SUB DrawForm (rct AS Rect, TitleStr AS STRING)
 FillRect rct, FormBkC
 DrawEdge rct, EdgeRAISED
 DrawCaption rct, TitleStr
END SUB
SUB DrawText (rct AS Rect, DrawStr AS STRING)
 DIM TempRect AS Rect
 DIM PosX AS INTEGER, PosY AS INTEGER
 DIM StrLen AS INTEGER
 DIM StrPos AS INTEGER
 DIM c AS STRING * 1
 DIM FontPos AS INTEGER
 DIM DrawMinX AS INTEGER, DrawMinY AS INTEGER
 DIM DrawMaxX AS INTEGER, DrawMaxY AS INTEGER
 DIM DrawY AS INTEGER
 DIM DrawX1 AS INTEGER, DrawX2 AS INTEGER
 DIM ExitFlags AS INTEGER
 DIM I AS INTEGER
 DIM MinI AS INTEGER, MaxI AS INTEGER
 DIM TempNum AS INTEGER
 PosX = rct.Left + TextStepX
 PosY = rct.Top + TextStepY
 TempRect = rct
 'PRINT rct.Top, rct.Bottom
 SetRectMinMax TempRect, 0, 0, ScrWi, ScrHe
 IF RectIsNull(TempRect) THEN EXIT SUB
 RectAddSize TempRect, -1, -1
 'PRINT TempRect.Top, TempRect.Bottom
 DrawMinX = TempRect.Left - (CharWi - 1)
 DrawMinY = TempRect.Top - (CharHe - 1)
 DrawMaxX = TempRect.Right + (CharWi - 1)
 DrawMaxY = TempRect.Bottom + (CharHe - 1)
 'PRINT DrawMinY, DrawMaxY
 DrawX1 = PosX
 DrawY = PosY
 StrLen = LEN(DrawStr)
 IF StrLen = 0 THEN EXIT SUB
 StrPos = 1
 'PRINT StrLen
 DO
  c = MID$(DrawStr, StrPos, 1)
  FontPos = ASC(c)
  'PRINT TextLf; c; " ";
  IF ((FontPos = 13) OR (FontPos = 10)) AND TextLf THEN
   'PRINT FontPos
   DrawX1 = PosX
   DrawY = DrawY + LineAdd
   IF StrPos < StrLen OR FontPos = 13 THEN 'CrLf
    IF ASC(MID$(DrawStr, StrPos + 1, 1)) = 10 THEN StrPos = StrPos + 1
   END IF
  END IF
  IF DrawX1 + CharWi >= TempRect.Right THEN
   IF AutoLf THEN
    DrawX1 = PosX
    DrawY = DrawY + LineAdd
   ELSE
    ExitFlags = True
   END IF
  END IF
  IF DrawY >= DrawMinY AND DrawY <= DrawMaxY THEN
   DrawX2 = DrawX1 + CharWi - 1
   IF DrawX2 >= DrawMinX OR DrawX1 <= DrawMaxX THEN
    IF DrawX1 < TempRect.Left THEN DrawX1 = TempRect.Left
    IF DrawX1 > TempRect.Right THEN DrawX1 = TempRect.Right
    IF DrawX2 < TempRect.Left THEN DrawX2 = TempRect.Left
    IF DrawX2 > TempRect.Right THEN DrawX2 = TempRect.Right
    DrawX2 = DrawX2 - DrawX1
    TempNum = DrawY
    IF TempNum < TempRect.Top THEN TempNum = TempRect.Top
    IF TempNum > TempRect.Bottom THEN TempNum = TempRect.Bottom
    MinI = TempNum - DrawY
    
    TempNum = DrawY + CharHe - 1
    IF TempNum < TempRect.Top THEN TempNum = TempRect.Top
    IF TempNum > TempRect.Bottom THEN TempNum = TempRect.Bottom
    MaxI = TempNum - DrawY
    FOR I = MinI TO MaxI
     LINE (DrawX1, DrawY + I)-STEP(DrawX2, 0), TextC, , FontData(I, FontPos)
    NEXT I
   END IF
  END IF
  DrawX1 = DrawX1 + CharAdd
  StrPos = StrPos + 1
  IF StrPos > StrLen THEN ExitFlags = True
  'ExitFlags = True
 LOOP UNTIL ExitFlags
END SUB
SUB DrawTextEx (rct AS Rect, StepX AS INTEGER, StepY AS INTEGER, DrawStr AS STRING, c AS INTEGER)
 DIM tX AS INTEGER, tY AS INTEGER
 DIM tC AS INTEGER
 tX = TextStepX
 TextStepX = StepX
 tY = TextStepY
 TextStepY = StepY
 tC = TextC
 TextC = c
 DrawText rct, DrawStr
 TextStepX = tX
 TextStepY = tY
 TectX = tC
END SUB
SUB FillRect (rct AS Rect, c AS INTEGER)
 IF c AND OnlyLine THEN
  LINE (rct.Left, rct.Top)-(rct.Right - 1, rct.Bottom - 1), c AND &HFF, B
 ELSE
  LINE (rct.Left, rct.Top)-(rct.Right - 1, rct.Bottom - 1), c, BF
 END IF
END SUB
FUNCTION GetRectH% (rct AS Rect)
 GetRectH% = rct.Bottom - rct.Top
END FUNCTION
FUNCTION GetRectW% (rct AS Rect)
 GetRectW% = rct.Right - rct.Left
END FUNCTION
SUB GradH12 (rct AS Rect, cl%, cr%)
 DIM w AS INTEGER, h AS INTEGER
 DIM I AS INTEGER, J AS INTEGER, K AS INTEGER
 DIM DataArr(I) AS INTEGER
 DIM MapArr(I) AS INTEGER
 DIM Idx AS INTEGER
 DIM StartIdx AS INTEGER
 DIM Idx0 AS INTEGER, Idx1 AS INTEGER
 DIM ChanBytes AS INTEGER, ChanInts AS INTEGER
 DIM TempInt(0 TO 3) AS INTEGER
 'DIM TempNum AS INTEGER
 DIM c AS INTEGER
 w = GetRectW(rct)
 h = GetRectH(rct)
 'PRINT w, h
 IF h <= 0 THEN EXIT SUB
 IF w <= 2 THEN EXIT SUB
 ChanBytes = (w + 7) / 8
 ChanInts = (ChanBytes + 1) / 2
 REDIM MapArr(0 TO ChanBytes * 2 + 1) AS INTEGER 'ChanBytes*4/2=ChanBytes*2
 MapArr(0) = w
 MapArr(1) = 1
 w = w - 1
 h = h - 1
 REDIM DataArr(0 TO w) AS INTEGER
 FOR I = 0 TO w
  DataArr(I) = I * &H100& / w
 NEXT I
 IF (ChanBytes AND 1) = 0 THEN
  FOR I = 0 TO h
   StartIdx = 2
   FOR J = 0 TO w
    Idx = J AND &HF
    IF BaseLightnessMatrix(Idx, I AND &HF) >= DataArr(J) THEN c = cl% ELSE c = cr%
    FOR K = 0 TO 3
     IF BitMaskInt(7 - K) AND c THEN TempInt(K) = TempInt(K) OR BitMaskInt(Idx)
    NEXT K
    IF Idx = &HF OR J = w THEN
     Idx0 = StartIdx
     FOR K = 0 TO 3
      MapArr(Idx0) = TempInt(K)
      Idx0 = Idx0 + ChanInts
      TempInt(K) = 0
     NEXT K
     StartIdx = StartIdx + 1
    END IF
   NEXT J
   PUT (rct.Left, rct.Top + I), MapArr, PSET
  NEXT I
 ELSE
  DIM TempArr(0 TO ChanInts - 1, 0 TO 1) AS INTEGER
  FOR I = 0 TO h
   StartIdx = 2
   Idx1 = 0
   FOR J = 0 TO w
    Idx = J AND &HF
    IF LightnessMatrix(Idx, I AND &HF) >= DataArr(J) THEN c = cl% ELSE c = cr%
    FOR K = 0 TO 3
     IF BitMaskInt(7 - K) AND c THEN TempInt(K) = TempInt(K) OR BitMaskInt(Idx)
    NEXT K
    IF Idx = &HF OR J = w THEN
     Idx0 = StartIdx
     FOR K = 0 TO 3 STEP 2
      MapArr(Idx0) = TempInt(K)
      TempArr(Idx1, K / 2) = TempInt(K + 1)
      Idx0 = Idx0 + ChanBytes
      TempInt(K) = 0
      TempInt(K + 1) = 0
     NEXT K
     StartIdx = StartIdx + 1
     Idx1 = Idx1 + 1
    END IF
   NEXT J
   Idx0 = VARSEG(MapArr(0))
   Idx1 = VARPTR(MapArr(0))
   Idx1 = Idx1 + 2 * 2 + ChanBytes
   MemCopy VARSEG(TempArr(0, 0)), VARPTR(TempArr(0, 0)), Idx0, Idx1, ChanBytes
   Idx1 = Idx1 + ChanBytes * 2
   MemCopy VARSEG(TempArr(0, 1)), VARPTR(TempArr(0, 1)), Idx0, Idx1, ChanBytes
   PUT (rct.Left, rct.Top + I), MapArr, PSET
  NEXT I
 END IF
END SUB
SUB GradV12 (rct AS Rect, ct%, cb%)
 DIM w AS INTEGER, h AS INTEGER
 DIM I AS INTEGER, J AS INTEGER, K AS INTEGER
 DIM DataArr(I) AS INTEGER
 DIM MapArr(I) AS INTEGER
 DIM Idx AS INTEGER
 DIM StartIdx AS INTEGER
 DIM Idx0 AS INTEGER, Idx1 AS INTEGER
 DIM ChanBytes AS INTEGER, ChanInts AS INTEGER
 DIM TempInt(0 TO 3) AS INTEGER
 DIM TempNum AS INTEGER
 DIM c AS INTEGER
 w = GetRectW(rct)
 h = GetRectH(rct)
 'PRINT w, h
 IF w <= 0 THEN EXIT SUB
 IF h <= 2 THEN EXIT SUB
 ChanBytes = (w + 7) / 8
 ChanInts = (ChanBytes + 1) / 2
 REDIM MapArr(0 TO ChanBytes * 2 + 1) AS INTEGER 'ChanBytes*4/2=ChanBytes*2
 MapArr(0) = w
 MapArr(1) = 1
 w = w - 1
 h = h - 1
 IF (ChanBytes AND 1) = 0 THEN
  FOR I = 0 TO h
   StartIdx = 2
   TempNum = I * &H100& / h
   FOR J = 0 TO w
    Idx = J AND &HF
    IF BaseLightnessMatrix(Idx, I AND &HF) >= TempNum THEN c = ct% ELSE c = cb%
    FOR K = 0 TO 3
     IF BitMaskInt(7 - K) AND c THEN TempInt(K) = TempInt(K) OR BitMaskInt(Idx)
    NEXT K
    IF Idx = &HF OR J = w THEN
     Idx0 = StartIdx
     FOR K = 0 TO 3
      MapArr(Idx0) = TempInt(K)
      Idx0 = Idx0 + ChanInts
      TempInt(K) = 0
     NEXT K
     StartIdx = StartIdx + 1
    END IF
   NEXT J
   PUT (rct.Left, rct.Top + I), MapArr, PSET
  NEXT I
 ELSE
  DIM TempArr(0 TO ChanInts - 1, 0 TO 1) AS INTEGER
  FOR I = 0 TO h
   StartIdx = 2
   Idx1 = 0
   TempNum = I * &HFF& / h
   FOR J = 0 TO w
    Idx = J AND &HF
    IF LightnessMatrix(Idx, I AND &HF) >= TempNum THEN c = ct% ELSE c = cb%
    FOR K = 0 TO 3
     IF BitMaskInt(7 - K) AND c THEN TempInt(K) = TempInt(K) OR BitMaskInt(Idx)
    NEXT K
    IF Idx = &HF OR J = w THEN
     Idx0 = StartIdx
     FOR K = 0 TO 3 STEP 2
      MapArr(Idx0) = TempInt(K)
      TempArr(Idx1, K / 2) = TempInt(K + 1)
      Idx0 = Idx0 + ChanBytes
      TempInt(K) = 0
      TempInt(K + 1) = 0
     NEXT K
     StartIdx = StartIdx + 1
     Idx1 = Idx1 + 1
    END IF
   NEXT J
   Idx0 = VARSEG(MapArr(0))
   Idx1 = VARPTR(MapArr(0))
   Idx1 = Idx1 + 2 * 2 + ChanBytes
   MemCopy VARSEG(TempArr(0, 0)), VARPTR(TempArr(0, 0)), Idx0, Idx1, ChanBytes
   Idx1 = Idx1 + ChanBytes * 2
   MemCopy VARSEG(TempArr(0, 1)), VARPTR(TempArr(0, 1)), Idx0, Idx1, ChanBytes
   PUT (rct.Left, rct.Top + I), MapArr, PSET
  NEXT I
 END IF
END SUB
SUB InitBit
 DIM I AS INTEGER
 FOR I = 0 TO 7
  BitMaskInt(I) = 2 ^ (7 - I)
 NEXT I
 BitMaskInt(8) = &H8000
 FOR I = 9 TO &HF
  BitMaskInt(I) = 2 ^ (&H17 - I)
 NEXT I
END SUB
SUB InitFont
 DIM I AS INTEGER, J AS INTEGER
 DIM TempPos AS INTEGER
 DIM TempByte AS INTEGER
 SCREEN 12
 WIDTH 80, 30
 DEF SEG = &HA000
 FOR I = 0 TO &HFF
  LINE (0, 0)-(&HF, &HF), 0, BF
  LOCATE 1, 1
  PRINT CHR$(I)
  TempPos = 0
  FOR J = 0 TO &HF
   TempByte = PEEK(TempPos)
   FontData(J, I) = MakeWord(0, TempByte)
   TempPos = TempPos + 80 '=640/8
  NEXT J
  'WHILE INKEY$ = "": WEND
 NEXT I
 DEF SEG
 TextC = 15
 TextLf = True
 AutoLf = False
 TextStepX = 0
 TextStepY = 0
 CharAdd = CharWi
 LineAdd = CharHe
 CLS
END SUB
SUB InitLightM
 DIM I AS INTEGER, J AS INTEGER, K AS INTEGER
 DIM TempStr AS STRING
 DIM TempNum AS INTEGER
 FOR I = 0 TO &HF
  FOR J = 0 TO &HF
   READ TempStr
   TempNum = VAL("&H" + TempStr)
   BaseLightnessMatrix(I, J) = TempNum
   '这样做是为了简化运算,原来需要乘除运算(R*&H100/&HFF>L),现在只需要比较(R>=L),具体可看RGB12函数
   IF TempNum <= &H7F THEN TempNum = TempNum + 1
   LightnessMatrix(I, J) = TempNum
  NEXT J
 NEXT I
 
 FOR I = 0 TO 1 'R
  FOR J = 0 TO 1 'G
   FOR K = 0 TO 1 'B
    RGBIndex(I, J, K) = I * 4 OR J * 2 OR K OR 8
   NEXT K
  NEXT J
 NEXT I
 RGBIndex(0, 0, 0) = 0
END SUB
SUB InitMemCopy
 DIM ASMStr AS STRING
 
 ASMStr = ""
 ASMStr = ASMStr + CHR$(85)                             'PUSH BP
 ASMStr = ASMStr + CHR$(137) + CHR$(229)                'MOV BP,SP
 ASMStr = ASMStr + CHR$(30)                             'PUSH DS
 ASMStr = ASMStr + CHR$(139) + CHR$(70) + CHR$(10)      'MOV AX,[BP+0A]
 ASMStr = ASMStr + CHR$(142) + CHR$(192)                'MOV ES,AX
 ASMStr = ASMStr + CHR$(139) + CHR$(70) + CHR$(14)      'MOV AX,[BP+0E]
 ASMStr = ASMStr + CHR$(142) + CHR$(216)                'MOV DS,AX
 ASMStr = ASMStr + CHR$(139) + CHR$(118) + CHR$(12)     'MOV SI,[BP+0C]
 ASMStr = ASMStr + CHR$(139) + CHR$(126) + CHR$(8)      'MOV DI,[BP+08]
 ASMStr = ASMStr + CHR$(139) + CHR$(78) + CHR$(6)       'MOV CX,[BP+06]
 ASMStr = ASMStr + CHR$(243)                            'REPZ
 ASMStr = ASMStr + CHR$(164)                            'MOVSB
 ASMStr = ASMStr + CHR$(31)                             'POP DS
 ASMStr = ASMStr + CHR$(93)                             'POP BP
 ASMStr = ASMStr + CHR$(203)                            'RETF
 
 'PRINT LEN(ASMStr)
 'STOP
 ASM.MemCopy = ASMStr
 
END SUB
FUNCTION MakeWord% (LoByte AS INTEGER, HiByte AS INTEGER)
 MakeWord% = (LoByte AND &HFF) OR ((HiByte AND &H7F) * &H100) OR ((HiByte AND &H80) <> 0 AND &H8000)
END FUNCTION
SUB MemCopy (fromseg%, fromoffset%, toseg%, tooffset%, bytes%)
 
 DEF SEG = VARSEG(ASM.MemCopy)
  CALL Absolute(BYVAL fromseg%, BYVAL fromoffset%, BYVAL toseg%, BYVAL tooffset%, BYVAL bytes%, VARPTR(ASM.MemCopy))
 DEF SEG
 
END SUB
SUB MoveRect (rct AS Rect, x%, y%)
 rct.Left = rct.Left + x%
 rct.Top = rct.Top + y%
 rct.Right = rct.Right + x%
 rct.Bottom = rct.Bottom + y%
END SUB
SUB RectAddSize (rct AS Rect, xAdd AS INTEGER, yAdd AS INTEGER)
 rct.Right = rct.Right + xAdd
 rct.Bottom = rct.Bottom + yAdd
END SUB
FUNCTION RectIsNull% (rct AS Rect)
 RectIsNull% = (rct.Right <= rct.Left) OR (rct.Bottom <= rct.Top)
END FUNCTION
FUNCTION RGB12% (x%, y%, R%, G%, B%)
 'DIM L AS INTEGER
 'L = LightnessMatrix(x% AND &HF, y% AND &HF)
 'RGB12% = RGBIndex((R% >= L) AND 1, (G% >= L) AND 1, (B% >= L) AND 1)
 
 '稍微移一下效果比较好
 RGB12% = RGBIndex((R% >= LightnessMatrix(x% AND &HF, y% AND &HF)) AND 1, (G% >= LightnessMatrix(x% + 1 AND &HF, y% AND &HF)) AND 1, (B% >= LightnessMatrix(x% AND &HF, y% + 1 AND &HF)) AND 1)
 
END FUNCTION
SUB SetRect (rct AS Rect, x1%, y1%, x2%, y2%)
 rct.Left = x1%
 rct.Top = y1%
 rct.Right = x2%
 rct.Bottom = y2%
END SUB
SUB SetRectMinMax (rct AS Rect, MinX%, MinY%, MaxX%, MaxY%)
 IF rct.Left < MinX% THEN rct.Left = MinX%
 IF rct.Top < MinY% THEN rct.Top = MinY%
 IF rct.Right > MaxX% THEN rct.Right = MaxX%
 IF rct.Bottom > MaxY% THEN rct.Bottom = MaxY%
END SUB
SUB SetRectPos (rct AS Rect, x%, y%)
 IF x% <> RectNoNum THEN rct.Right = x% + rct.Right - rct.Left: rct.Left = x%
 IF y% <> RectNoNum THEN rct.Bottom = y% + rct.Bottom - rct.Top: rct.Top = y%
END SUB
SUB SetRectSize (rct AS Rect, w%, h%)
 IF w% <> RectNoNum THEN rct.Right = rct.Left + w%
 IF h% <> RectNoNum THEN rct.Bottom = rct.Top + h%
END SUB
SUB SizeRect (rct AS Rect, x%, y%)
 rct.Left = rct.Left - x%
 rct.Top = rct.Top - y%
 rct.Right = rct.Right + x%
 rct.Bottom = rct.Bottom + y%
END SUB

 

代码打包下载(请修改后缀名)

0
0

查看评论
* 以上用户言论只代表其个人观点,不代表CSDN网站的观点或立场
    个人资料
    • 访问:301000次
    • 积分:3833
    • 等级:
    • 排名:第8310名
    • 原创:68篇
    • 转载:2篇
    • 译文:1篇
    • 评论:179条