FreeBasic
Главная
Вход
Регистрация
Пятница, 19.04.2024, 16:38Приветствую Вас Гость | RSS
[ Новые сообщения · Участники · Правила форума · Поиск · RSS ]
  • Страница 1 из 1
  • 1
Форум » Freebasic » Исходники » Красивый лист (Красивый лист)
Красивый лист
haavДата: Пятница, 15.06.2012, 13:22 | Сообщение # 1
Генералиссимус
Группа: Администраторы
Сообщений: 1361
Репутация: 49
Статус: Offline
Красивый лист



Данный пример был выполнен автором -Mikle- на языке VisualBasic 6.0. Его же использовали для сравнения быстродействия бейсиков.




Code
#Include "windows.bi"        

        Private Type Vector        
        x As Single        
        y As Single        
        End Type        

        Dim Shared bi32BitInfo As BITMAPINFO        
        Dim Shared Map(767, 1023) As Long        
        Declare Sub DrawFractal(vPos As Vector, vDir As Vector)        
        Declare Sub DrawLine(vP1 As Vector, vP2 As Vector)        
        Declare Sub Main()        
        Dim Shared QSpeed As Double        

        Main '<- вход        

        Private Function QTime() As Double        
         Dim QD As LARGE_INTEGER, t As Double        
         QueryPerformanceCounter @QD        
         If QD.LowPart < 0 Then t = QD.LowPart + 4294967296 Else t = QD.LowPart        
         If QD.HighPart < 0 Then t = t + (QD.HighPart + 4294967296) * 4294967296 Else t = t + QD.HighPart * 4294967296        
         QTime = t * QSpeed        
        End Function        

        Private Sub QTimeInit()        
         Dim QD As LARGE_INTEGER        
         QueryPerformanceFrequency @QD        
         If QD.LowPart < 0 Then QSpeed = QD.LowPart + 4294967296 Else QSpeed = QD.LowPart        
         If QD.HighPart < 0 Then QSpeed = QSpeed + (QD.HighPart + 4294967296) * 4294967296 Else QSpeed = QSpeed + QD.HighPart * 4294967296        
         QSpeed = 1 / QSpeed        
        End Sub        

        Private Sub Main()        
         Dim vP As Vector, vD As Vector        
         Dim t1 As Single, t2 As Single        
         Dim msg As MSG        

         QTimeInit        
         vP.x = 40        
         vP.y = 500        
         vD.x = 87        
         vD.y = -54        

         t1 = QTime        
         DrawFractal vP, vD        
         t2 = QTime        

         With bi32BitInfo.bmiHeader        
          .biBitCount = 32        
          .biPlanes = 1        
          .biSize = Len(bi32BitInfo.bmiHeader)        
          .biWidth = 1024        
          .biHeight = -768        
          .biSizeImage = 4 * 1024 * 768        
         End With        
         Var hwnd=CreateWindowEx(0,"#32770","",WS_VISIBLE Or WS_OVERLAPPEDWINDOW,10,10,1024,768,0,0,0,0)        
         Dim wRect As RECT        
         GetWindowRect(hWnd,@wRect)        
         wRect.right   = wRect.right-wRect.left        
         wRect.bottom  = wRect.bottom-wRect.top        
         MoveWindow(hWnd,(GetSystemMetrics(0) Shr 1) - (wRect.right Shr 1),_        
         (GetSystemMetrics(1) Shr 1) - (wRect.bottom Shr 1),_        
         wRect.right, wRect.bottom, 1)        
         Var hdc = GetDC(hwnd)        
         SetDIBitsToDevice( hdc, 0, 0, 1024, 768, 0, 0, 0, 768, @Map(0, 0), @bi32BitInfo, 0)        
         SetBkColor(hDC,&h0)        
         SetTextColor(hDC,&hffffff)        
         TextOut(hdc,20,20,Str(t2-t1),Len(Str(t2-t1)))        
         DeleteDC(hdc)        
         While GetMessage(@msg,0,0,0)        
          DispatchMessage(@msg)        
          If msg.message=WM_COMMAND Then Exit While        
         Wend        
        End Sub        

        Private Sub DrawFractal(vPos As Vector, vDir As Vector)        
         Dim vP As Vector, vD As Vector        

         If vDir.x * vDir.x + vDir.y * vDir.y < 0.017 Then Exit Sub        
         vP.x = vPos.x + vDir.x        
         vP.y = vPos.y + vDir.y        
         DrawLine vPos, vP        

         vD.x = vDir.x * 0.9 - vDir.y * 0.04        
         vD.y = vDir.y * 0.9 + vDir.x * 0.04        
         DrawFractal vP, vD        
         vD.x = vDir.x * 0.15 + vDir.y * 0.24        
         vD.y = vDir.y * 0.15 - vDir.x * 0.24        
         DrawFractal vP, vD        
         vD.x = vDir.x * 0.14 - vDir.y * 0.25        
         vD.y = vDir.y * 0.14 + vDir.x * 0.25        
         DrawFractal vP, vD        
        End Sub        

        Private Sub DrawLine(vP1 As Vector, vP2 As Vector)        
         Dim x As Single, y As Single, k As Single, dx As Single, dy As Single        

         dx = vP2.x - vP1.x        
         dy = vP2.y - vP1.y        
         If Abs(dx) < Abs(dy) Then        
          k = dx / dy        
          If vP2.y > vP1.y Then        
           y = vP1.y        
           x = vP1.x        
           While y < vP2.y        
            Map(y, x) = &H50BB50        
            x = x + k        
            y = y + 1        
           Wend        
          Else        
           y = vP2.y        
           x = vP1.x        
           While y < vP1.y        
            Map(y, x) = &H40FF30        
            x = x + k        
            y = y + 1        
           Wend        
          End If        
         Else        
          k = dy / dx        
          If vP2.x > vP1.x Then        
           x = vP1.x        
           y = vP1.y        
           While x < vP2.x        
            Map(y, x) = &HA0AF20        
            y = y + k        
            x = x + 1        
           Wend        
          Else        
           x = vP2.x        
           y = vP1.y        
           While x < vP1.x        
            Map(y, x) = &H609F30        
            y = y + k        
            x = x + 1        
           Wend        
          End If        
         End If        
        End Sub
Прикрепления: 3712792.png (164.9 Kb)


Вы сохраняете власть над людьми покуда оставляете им что-то…Отберите у человека все, и этот человек уже будет неподвластен вам…
 
DEPOzitДата: Четверг, 21.06.2012, 00:19 | Сообщение # 2
Рядовой
Группа: Друзья
Сообщений: 8
Репутация: 0
Статус: Offline
Лист симпатичный, но как тест честно говоря никакой. Задействовано одно ядро, тест очень короткий, результаты прыгают и т.д. Предлагаю создать адекватный бенчмарк (включая к примеру излюбленные решения линейных уравнений) и прогнать его на разных компиляторах (не только на бейсике). Думаю, это интересно будет многим при выборе языка программирования.
Кстати пробовал ранее делать бенч, в качестве интерфейса использовал твою библиотеку. Назвать его адекватным тоже сложно – менее мощные процессоры показывали более высокий результат:
Code
#Include "window9.bi"

Dim As integer hwnd,event
hwnd=OpenWindow("DEPOzit - Тест CPU",200,10,500,500)
WindowStartDraw(hwnd)
   fillrectdraw(40,40,&hffffff)  
   FontDraw(LoadFont("arial",22))
   TextDraw(150,100,"Please Wait...",&hffffff)
     FontDraw(LoadFont("arial",14))
TextDraw(40,140,"Постарайтесь не совершать никаких действий",&hffffff)
     FontDraw(LoadFont("arial",18))
TextDraw(80,170,"Время тестирования: 30 сек",&hffffff)
StopDraw  

     Dim Shared tim As double
     Dim Shared a As LongInt
     Dim Shared a2 As LongInt
     Dim Shared a3 As LongInt
     Dim Shared a4 As LongInt
     Dim Shared rez As Integer
     Dim Shared z As Integer
     tim=Timer
Sub ONE(param As Any Ptr)
     Dim a11 As Double
     Dim b11 As Double
     Dim x11 As Double
      
     Do
      If tim+30<=Timer Then Exit Do
         a+=1         
a11=1+Rnd*10000
b11=1+Rnd*10000
x11=(-1)*b11/a11
     Loop     
End Sub

Sub ONE2(param As Any Ptr)
     Dim a21 As Double
     Dim b21 As double
     Dim x21 As Double
    Do
     a2+=1
a21=1+Rnd*10000
b21=1+Rnd*10000
x21=(-1)*b21/a21
If z=1 Then Exit Do
    Loop   
End Sub

Sub ONE3(param As Any Ptr)
     Dim a31 As Double
     Dim b31 As double
     Dim x31 As Double
    Do
         a3+=1
a31=1+Rnd*10000
b31=1+Rnd*10000
x31=(-1)*b31/a31
If z=1 Then Exit Do
    Loop   
End Sub

Sub ONE4(param As Any Ptr)
     Dim a41 As Double
     Dim b41 As double
     Dim x41 As Double
    Do
         a4+=1
a41=1+Rnd*10000
b41=1+Rnd*10000
x41=(-1)*41/41
If z=1 Then Exit Do
    Loop   
End Sub

Dim As Any Ptr ID
Dim As Any Ptr ID2
Dim As Any Ptr ID3
Dim As Any Ptr ID4

ID=ThreadCreate(@ONE())
ID2=ThreadCreate(@ONE2())
ID3=ThreadCreate(@ONE3())
ID4=ThreadCreate(@ONE4())

ThreadWait(ID)
z=1

rez=(a+a2+a3+a4)/10000
Do
WindowStartDraw(hwnd)
   fillrectdraw(40,40,&hffffff)  
   FontDraw(LoadFont("arial",12))
   TextDraw(10,10,"Производительность Вашего процессора:",&hffffff)
   FontDraw(LoadFont("arial",12,0,1))
     TextDraw(330,10,Str(Int(rez/40))+" очков",&hffffff)

StopDraw  

  event=WaitEvent()
  If event=EventClose Then End
Loop


Сообщение отредактировал DEPOzit - Четверг, 21.06.2012, 00:31
 
haavДата: Четверг, 21.06.2012, 08:29 | Сообщение # 3
Генералиссимус
Группа: Администраторы
Сообщений: 1361
Репутация: 49
Статус: Offline
Quote
Предлагаю создать адекватный бенчмарк (включая к примеру излюбленные решения линейных уравнений) и прогнать его на разных компиляторах (не только на бейсике). Думаю, это интересно будет многим при выборе языка программирования.


Ты же видел в тесте приняли участие только три бейсика, адаптировать пример под остальные даже никто не стал. Ну а учить другие бейсики (даже в рамках примера) из-за одного теста желания нет. А про другие языки....


Вы сохраняете власть над людьми покуда оставляете им что-то…Отберите у человека все, и этот человек уже будет неподвластен вам…
 
DEPOzitДата: Четверг, 21.06.2012, 12:56 | Сообщение # 4
Рядовой
Группа: Друзья
Сообщений: 8
Репутация: 0
Статус: Offline
Так не обязательно сложный пример, а наоборот – тот который можно адаптировать под любой язык, не требуя при этом глубоких знаний языка. Думаю все это реально и не так сложно.
 
haavДата: Четверг, 21.06.2012, 14:04 | Сообщение # 5
Генералиссимус
Группа: Администраторы
Сообщений: 1361
Репутация: 49
Статус: Offline
В этом я мало смыслю, если знаешь напиши пример. Я бывает пробую разные компиляторы. Потихоничку можно примерчик адаптировать на различные диалекты и записывать результат, а может кто еще поможет. Накопится побольше компиляторов, можно будет на википедию закинуть табличкой.

Вы сохраняете власть над людьми покуда оставляете им что-то…Отберите у человека все, и этот человек уже будет неподвластен вам…
 
Форум » Freebasic » Исходники » Красивый лист (Красивый лист)
  • Страница 1 из 1
  • 1
Поиск: